import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield,
threadDelay, forkIO, childHandler )
import qualified GHC.Conc
-import GHC.IOBase ( IO(..) )
-import GHC.IOBase ( unsafeInterleaveIO )
-import GHC.IOBase ( newIORef, readIORef, writeIORef )
+import GHC.IO ( IO(..), unsafeInterleaveIO )
+import GHC.IORef ( newIORef, readIORef, writeIORef )
import GHC.Base
import System.Posix.Types ( Fd )
#ifdef mingw32_HOST_OS
import Foreign.C
import System.IO
-import GHC.Handle
#endif
#endif
#endif
#ifdef __GLASGOW_HASKELL__
-import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+import GHC.MVar ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
)
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.IOBase
+import GHC.IO hiding ( onException, finally )
import Data.Maybe
#else
import Prelude hiding (catch)
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.IOBase
+import GHC.IO hiding (finally,onException)
+import GHC.IO.Exception
+import GHC.Exception
import GHC.Show
-import GHC.IOBase
import GHC.Exception hiding ( Exception )
import GHC.Conc
#endif
-> (e -> IO a) -- ^ Handler to invoke if an exception is raised
-> IO a
#if __GLASGOW_HASKELL__
-catch = GHC.IOBase.catchException
+catch = GHC.IO.catchException
#elif __HUGS__
catch m h = Hugs.Exception.catchException m h'
where h' e = case fromException e of
#ifdef __GLASGOW_HASKELL__
import GHC.ST ( ST, runST, fixST, unsafeInterleaveST )
import GHC.Base ( RealWorld )
-import GHC.IOBase ( stToIO, unsafeIOToST, unsafeSTToIO )
+import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO )
#endif
instance MonadFix (ST s) where
import GHC.Base
import GHC.Num
import GHC.Show
-import GHC.IOBase ( IO )
-import qualified GHC.IOBase as New
+import GHC.IO ( IO )
+import GHC.IO.Handle.FD ( stdout )
+import qualified GHC.IO as New
+import qualified GHC.IO.Exception as New
import GHC.Conc hiding (setUncaughtExceptionHandler,
getUncaughtExceptionHandler)
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Foreign.C.String ( CString, withCString )
-import GHC.Handle ( stdout, hFlush )
+import GHC.IO.Handle ( hFlush )
#endif
#ifdef __HUGS__
import GHC.Show ( Show(..) )
import GHC.Int ( Int64 )
-import GHC.IOBase ( IO, IOArray, newIOArray,
- unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO,
- IORef, newIORef, readIORef, writeIORef )
+import GHC.IO
+import GHC.IOArray
+import GHC.IORef
#else
import Data.Char ( ord )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.STRef
-import GHC.IOBase
+import GHC.IO
+import GHC.IORef hiding (atomicModifyIORef)
+import qualified GHC.IORef
#if !defined(__PARALLEL_HASKELL__)
import GHC.Weak
#endif
--
atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
#if defined(__GLASGOW_HASKELL__)
-atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
+atomicModifyIORef = GHC.IORef.atomicModifyIORef
#elif defined(__HUGS__)
atomicModifyIORef = plainModifyIORef -- Hugs has no preemption
import GHC.Err (undefined)
import GHC.Num (Integer, fromInteger, (+))
import GHC.Real ( rem, Ratio )
-import GHC.IOBase (IORef,newIORef,unsafePerformIO)
+import GHC.IORef (IORef,newIORef)
+import GHC.IO (IO, unsafePerformIO,block)
-- These imports are so we can define Typeable instances
-- It'd be better to give Typeable instances in the modules themselves
-- but they all have to be compiled before Typeable
-import GHC.IOBase ( IOArray, IO, MVar, Handle, block )
+import GHC.IOArray
+import GHC.MVar
import GHC.ST ( ST )
import GHC.STRef ( STRef )
import GHC.Ptr ( Ptr, FunPtr )
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
--- Types defined in GHC.IOBase
+-- Types defined in GHC.MVar
INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
#endif
#endif
INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+#endif
INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
import Data.Maybe
#if __GLASGOW_HASKELL__
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
+import GHC.IO.Handle.Types
import GHC.Num
import GHC.Base
#elif __HUGS__
import GHC.List
import GHC.Real
import GHC.Num
-import GHC.IOBase
+import GHC.IO
import GHC.Base
#else
import Data.Char ( chr, ord )
#ifndef __NHC__
-import {-# SOURCE #-} Foreign.Storable
+import Foreign.Storable
import Data.Bits ( Bits(..) )
import Data.Int ( Int8, Int16, Int32, Int64 )
import Data.Word ( Word8, Word16, Word32, Word64 )
) where
#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase ( IO )
+import GHC.IO ( IO )
import GHC.Ptr ( Ptr )
import GHC.ForeignPtr ( ForeignPtr )
import qualified GHC.ForeignPtr
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.IOBase
+import GHC.IO
import GHC.Num
import GHC.Err ( undefined )
import GHC.ForeignPtr
#ifdef __GLASGOW_HASKELL__
import Foreign.ForeignPtr ( FinalizerPtr )
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
import GHC.Real
import GHC.Ptr
import GHC.Err
import Foreign.Marshal.Utils (copyBytes, moveBytes)
#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
+import GHC.IO
import GHC.Num
import GHC.List
import GHC.Err
#endif
import GHC.Base
import GHC.Num
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
#endif
-- exported functions
import GHC.Base ( Int, Monad(..), (.), not )
import GHC.Err ( undefined )
import GHC.Exception ( throw )
-import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef,
- block, unblock, catchAny )
+import GHC.IO ( IO, block, unblock, catchAny )
+import GHC.IORef ( IORef, newIORef, readIORef, writeIORef )
import GHC.List ( elem, length )
import GHC.Num ( Num(..) )
#else
import Foreign.Marshal.Alloc ( malloc, alloca )
#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
+import GHC.IO
import GHC.Real ( fromIntegral )
import GHC.Num
import GHC.Base
#ifdef __GLASGOW_HASKELL__
import GHC.Ptr
-import GHC.IOBase
+import GHC.IO
import GHC.Base
import GHC.Num
import GHC.Read
import GHC.Word
import GHC.Ptr
import GHC.Err
-import GHC.IOBase
+import GHC.IO
import GHC.Base
#else
import Data.Int
+++ /dev/null
-
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
-
-module Foreign.Storable where
-
-import GHC.Base
-import GHC.Int
-import GHC.Word
-
-class Storable a
-
-instance Storable Int8
-instance Storable Int16
-instance Storable Int32
-instance Storable Int64
-instance Storable Word8
-instance Storable Word16
-instance Storable Word32
-instance Storable Word64
-instance Storable Float
-instance Storable Double
-
, threadWaitRead -- :: Int -> IO ()
, threadWaitWrite -- :: Int -> IO ()
- -- * MVars
- , MVar(..)
- , newMVar -- :: a -> IO (MVar a)
- , newEmptyMVar -- :: IO (MVar a)
- , takeMVar -- :: MVar a -> IO a
- , putMVar -- :: MVar a -> a -> IO ()
- , tryTakeMVar -- :: MVar a -> IO (Maybe a)
- , tryPutMVar -- :: MVar a -> a -> IO Bool
- , isEmptyMVar -- :: MVar a -> IO Bool
- , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
-
-- * TVars
, STM(..)
, atomically -- :: STM a -> IO a
, unsafeIOToSTM -- :: IO a -> STM a
-- * Miscellaneous
+ , withMVar
#ifdef mingw32_HOST_OS
, asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
, asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
import Data.Maybe
import GHC.Base
-import {-# SOURCE #-} GHC.Handle
-import GHC.IOBase
+import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
+import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
+import GHC.IO
+import GHC.IO.Exception
+import GHC.Exception
+import GHC.IORef
+import GHC.MVar
import GHC.Num ( Num(..) )
import GHC.Real ( fromIntegral )
#ifndef mingw32_HOST_OS
+import GHC.IOArray
import GHC.Arr ( inRange )
#endif
#ifdef mingw32_HOST_OS
import GHC.Read ( Read )
import GHC.Enum ( Enum )
#endif
-import GHC.Exception ( SomeException(..), throw )
import GHC.Pack ( packCString# )
import GHC.Ptr ( Ptr(..) )
-import GHC.STRef
import GHC.Show ( Show(..), showString )
import Data.Typeable
import GHC.Err
\end{code}
-%************************************************************************
-%* *
-\subsection[mvars]{M-Structures}
-%* *
-%************************************************************************
-
-M-Vars are rendezvous points for concurrent threads. They begin
-empty, and any attempt to read an empty M-Var blocks. When an M-Var
-is written, a single blocked thread may be freed. Reading an M-Var
-toggles its state from full back to empty. Therefore, any value
-written to an M-Var may only be read once. Multiple reads and writes
-are allowed, but there must be at least one read between any two
-writes.
+MVar utilities
\begin{code}
---Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
-
--- |Create an 'MVar' which is initially empty.
-newEmptyMVar :: IO (MVar a)
-newEmptyMVar = IO $ \ s# ->
- case newMVar# s# of
- (# s2#, svar# #) -> (# s2#, MVar svar# #)
-
--- |Create an 'MVar' which contains the supplied value.
-newMVar :: a -> IO (MVar a)
-newMVar value =
- newEmptyMVar >>= \ mvar ->
- putMVar mvar value >>
- return mvar
-
--- |Return the contents of the 'MVar'. If the 'MVar' is currently
--- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
--- the 'MVar' is left empty.
---
--- There are two further important properties of 'takeMVar':
---
--- * 'takeMVar' is single-wakeup. That is, if there are multiple
--- threads blocked in 'takeMVar', and the 'MVar' becomes full,
--- only one thread will be woken up. The runtime guarantees that
--- the woken thread completes its 'takeMVar' operation.
---
--- * When multiple threads are blocked on an 'MVar', they are
--- woken up in FIFO order. This is useful for providing
--- fairness properties of abstractions built using 'MVar's.
---
-takeMVar :: MVar a -> IO a
-takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
-
--- |Put a value into an 'MVar'. If the 'MVar' is currently full,
--- 'putMVar' will wait until it becomes empty.
---
--- There are two further important properties of 'putMVar':
---
--- * 'putMVar' is single-wakeup. That is, if there are multiple
--- threads blocked in 'putMVar', and the 'MVar' becomes empty,
--- only one thread will be woken up. The runtime guarantees that
--- the woken thread completes its 'putMVar' operation.
---
--- * When multiple threads are blocked on an 'MVar', they are
--- woken up in FIFO order. This is useful for providing
--- fairness properties of abstractions built using 'MVar's.
---
-putMVar :: MVar a -> a -> IO ()
-putMVar (MVar mvar#) x = IO $ \ s# ->
- case putMVar# mvar# x s# of
- s2# -> (# s2#, () #)
-
--- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
--- returns immediately, with 'Nothing' if the 'MVar' was empty, or
--- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
--- the 'MVar' is left empty.
-tryTakeMVar :: MVar a -> IO (Maybe a)
-tryTakeMVar (MVar m) = IO $ \ s ->
- case tryTakeMVar# m s of
- (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty
- (# s', _, a #) -> (# s', Just a #) -- MVar is full
-
--- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
--- attempts to put the value @a@ into the 'MVar', returning 'True' if
--- it was successful, or 'False' otherwise.
-tryPutMVar :: MVar a -> a -> IO Bool
-tryPutMVar (MVar mvar#) x = IO $ \ s# ->
- case tryPutMVar# mvar# x s# of
- (# s, 0# #) -> (# s, False #)
- (# s, _ #) -> (# s, True #)
-
--- |Check whether a given 'MVar' is empty.
---
--- Notice that the boolean value returned is just a snapshot of
--- the state of the MVar. By the time you get to react on its result,
--- the MVar may have been filled (or emptied) - so be extremely
--- careful when using this operation. Use 'tryTakeMVar' instead if possible.
-isEmptyMVar :: MVar a -> IO Bool
-isEmptyMVar (MVar mv#) = IO $ \ s# ->
- case isEmptyMVar# mv# s# of
- (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
-
--- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
--- "System.Mem.Weak" for more about finalizers.
-addMVarFinalizer :: MVar a -> IO () -> IO ()
-addMVarFinalizer (MVar m) finalizer =
- IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }
+withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar m io =
+ block $ do
+ a <- takeMVar m
+ b <- catchAny (unblock (io a))
+ (\e -> do putMVar m a; throw e)
+ putMVar m a
+ return b
\end{code}
-
%************************************************************************
%* *
\subsection{Thread waiting}
type USecs = Word64
--- XXX: move into GHC.IOBase from Data.IORef?
-atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
-atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
-
foreign import ccall unsafe "getUSecOfDay"
getUSecOfDay :: IO USecs
getUncaughtExceptionHandler :: IO (SomeException -> IO ())
getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
-
-
-withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io =
- block $ do
- a <- takeMVar m
- b <- catchAny (unblock (io a))
- (\e -> do putMVar m a; throw e)
- putMVar m a
- return b
\end{code}
import Foreign
import Foreign.C
-import GHC.IOBase
+import GHC.IO.FD
+import GHC.IO.Exception
+import GHC.IO.Handle.Types
+import GHC.IO.Handle.Internals
import GHC.Conc
-import GHC.Handle
-import Control.Exception (onException)
+import Control.Concurrent.MVar
+import Data.Typeable
data Handler
= Default
flushConsole :: Handle -> IO ()
flushConsole h =
- wantReadableHandle "flushConsole" h $ \ h_ ->
- throwErrnoIfMinus1Retry_ "flushConsole"
- (flush_console_fd (fromIntegral (haFD h_)))
+ wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} ->
+ case cast dev of
+ Nothing -> ioException $
+ IOError (Just h) IllegalOperation "flushConsole"
+ "handle is not a file descriptor" Nothing Nothing
+ Just fd -> do
+ throwErrnoIfMinus1Retry_ "flushConsole" $
+ flush_console_fd (fromIntegral (fdFD fd))
foreign import ccall unsafe "consUtils.h flush_input_console__"
flush_console_fd :: CInt -> IO CInt
--- XXX Copied from Control.Concurrent.MVar
-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
-modifyMVar m io =
- block $ do
- a <- takeMVar m
- (a',b) <- unblock (io a) `onException` putMVar m a
- putMVar m a'
- return b
#endif /* mingw32_HOST_OS */
import GHC.Show
import GHC.List ( null )
import GHC.Base
-import GHC.IOBase
+import GHC.IO
+import GHC.IORef
import GHC.STRef ( STRef(..) )
import GHC.Ptr ( Ptr(..), FunPtr(..) )
import GHC.Err
-{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
-{-# OPTIONS_GHC -fno-warn-unused-matches #-}
-{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_HADDOCK hide #-}
-
-#undef DEBUG_DUMP
-#undef DEBUG
-
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Handle
-- Stability : internal
-- Portability : non-portable
--
--- This module defines the basic operations on I\/O \"handles\".
+-- Backwards-compatibility interface
--
-----------------------------------------------------------------------------
-- #hide
-module GHC.Handle (
+
+module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle.Base instead" #-} (
withHandle, withHandle', withHandle_,
wantWritableHandle, wantReadableHandle, wantSeekableHandle,
- newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
- flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
- fillReadBuffer, fillReadBufferWithoutBlocking,
- readRawBuffer, readRawBufferPtr,
- readRawBufferNoBlock, readRawBufferPtrNoBlock,
- writeRawBuffer, writeRawBufferPtr,
-
-#ifndef mingw32_HOST_OS
- unlockFile,
-#endif
+-- newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
+-- flushWriteBufferOnly, flushWriteBuffer,
+-- flushReadBuffer,
+-- fillReadBuffer, fillReadBufferWithoutBlocking,
+-- readRawBuffer, readRawBufferPtr,
+-- readRawBufferNoBlock, readRawBufferPtrNoBlock,
+-- writeRawBuffer, writeRawBufferPtr,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
stdin, stdout, stderr,
- IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
- hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode,
+ IOMode(..), openFile, openBinaryFile,
+-- fdToHandle_stat,
+ fdToHandle, fdToHandle',
+ hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead_,
+ hSetBuffering, hSetBinaryMode,
hFlush, hDuplicate, hDuplicateTo,
hClose, hClose_help,
hShow,
-#ifdef DEBUG_DUMP
- puts,
-#endif
-
) where
-import Control.Monad
-import Data.Maybe
-import Foreign
-import Foreign.C
-import System.IO.Error
-import System.Posix.Internals
-import System.Posix.Types
-
-import GHC.Real
-
-import GHC.Arr
-import GHC.Base
-import GHC.Read ( Read )
-import GHC.List
-import GHC.IOBase
-import GHC.Exception
-import GHC.Enum
-import GHC.Num ( Integer, Num(..) )
-import GHC.Show
-#if defined(DEBUG_DUMP)
-import GHC.Pack
-#endif
-
-import GHC.Conc
-
--- -----------------------------------------------------------------------------
--- TODO:
-
--- hWaitForInput blocks (should use a timeout)
-
--- unbuffered hGetLine is a bit dodgy
-
--- hSetBuffering: can't change buffering on a stream,
--- when the read buffer is non-empty? (no way to flush the buffer)
-
--- ---------------------------------------------------------------------------
--- Are files opened by default in text or binary mode, if the user doesn't
--- specify?
-
-dEFAULT_OPEN_IN_BINARY_MODE :: Bool
-dEFAULT_OPEN_IN_BINARY_MODE = False
-
--- ---------------------------------------------------------------------------
--- Creating a new handle
-
-newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle filepath finalizer hc = do
- m <- newMVar hc
- addMVarFinalizer m (finalizer m)
- return (FileHandle filepath m)
-
--- ---------------------------------------------------------------------------
--- Working with Handles
-
-{-
-In the concurrent world, handles are locked during use. This is done
-by wrapping an MVar around the handle which acts as a mutex over
-operations on the handle.
-
-To avoid races, we use the following bracketing operations. The idea
-is to obtain the lock, do some operation and replace the lock again,
-whether the operation succeeded or failed. We also want to handle the
-case where the thread receives an exception while processing the IO
-operation: in these cases we also want to relinquish the lock.
-
-There are three versions of @withHandle@: corresponding to the three
-possible combinations of:
-
- - the operation may side-effect the handle
- - the operation may return a result
-
-If the operation generates an error or an exception is raised, the
-original handle is always replaced [ this is the case at the moment,
-but we might want to revisit this in the future --SDM ].
--}
-
-{-# INLINE withHandle #-}
-withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
-withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
-
-withHandle' :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
- `catchException` \ex -> ioError (augmentIOError ex fun h)
- checkBufferInvariants h'
- putMVar m h'
- return v
-
-{-# INLINE withHandle_ #-}
-withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
-withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
-withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
-
-withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
-withHandle_' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
- `catchException` \ex -> ioError (augmentIOError ex fun h)
- checkBufferInvariants h_
- putMVar m h_
- return v
-
-withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
-withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
-withAllHandles__ fun h@(DuplexHandle _ r w) act = do
- withHandle__' fun h r act
- withHandle__' fun h w act
-
-withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
- -> IO ()
-withHandle__' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
- `catchException` \ex -> ioError (augmentIOError ex fun h)
- checkBufferInvariants h'
- putMVar m h'
- return ()
-
-augmentIOError :: IOException -> String -> Handle -> IOException
-augmentIOError ioe@IOError{ ioe_filename = fp } fun h
- = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }
- where filepath
- | Just _ <- fp = fp
- | otherwise = case h of
- FileHandle path _ -> Just path
- DuplexHandle path _ _ -> Just path
-
--- ---------------------------------------------------------------------------
--- Wrapper for write operations.
-
-wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantWritableHandle fun h@(FileHandle _ m) act
- = wantWritableHandle' fun h m act
-wantWritableHandle fun h@(DuplexHandle _ _ m) act
- = wantWritableHandle' fun h m act
- -- ToDo: in the Duplex case, we don't need to checkWritableHandle
-
-wantWritableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
-wantWritableHandle' fun h m act
- = withHandle_' fun h m (checkWritableHandle act)
-
-checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
-checkWritableHandle act handle_
- = case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- ReadHandle -> ioe_notWritable
- ReadWriteHandle -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
- new_buf <-
- if not (bufferIsWritable buf)
- then do b <- flushReadBuffer (haFD handle_) buf
- return b{ bufState=WriteBuffer }
- else return buf
- writeIORef ref new_buf
- act handle_
- _other -> act handle_
-
--- ---------------------------------------------------------------------------
--- Wrapper for read operations.
-
-wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantReadableHandle fun h@(FileHandle _ m) act
- = wantReadableHandle' fun h m act
-wantReadableHandle fun h@(DuplexHandle _ m _) act
- = wantReadableHandle' fun h m act
- -- ToDo: in the Duplex case, we don't need to checkReadableHandle
-
-wantReadableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
-wantReadableHandle' fun h m act
- = withHandle_' fun h m (checkReadableHandle act)
-
-checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
-checkReadableHandle act handle_ =
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notReadable
- WriteHandle -> ioe_notReadable
- ReadWriteHandle -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
- when (bufferIsWritable buf) $ do
- new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
- writeIORef ref new_buf{ bufState=ReadBuffer }
- act handle_
- _other -> act handle_
-
--- ---------------------------------------------------------------------------
--- Wrapper for seek operations.
-
-wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
- ioException (IOError (Just h) IllegalOperation fun
- "handle is not seekable" Nothing Nothing)
-wantSeekableHandle fun h@(FileHandle _ m) act =
- withHandle_' fun h m (checkSeekableHandle act)
-
-checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
-checkSeekableHandle act handle_ =
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notSeekable
- _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
- | otherwise -> ioe_notSeekable_notBin
-
--- -----------------------------------------------------------------------------
--- Handy IOErrors
-
-ioe_closedHandle, ioe_EOF,
- ioe_notReadable, ioe_notWritable,
- ioe_notSeekable, ioe_notSeekable_notBin :: IO a
-
-ioe_closedHandle = ioException
- (IOError Nothing IllegalOperation ""
- "handle is closed" Nothing Nothing)
-ioe_EOF = ioException
- (IOError Nothing EOF "" "" Nothing Nothing)
-ioe_notReadable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for reading" Nothing Nothing)
-ioe_notWritable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for writing" Nothing Nothing)
-ioe_notSeekable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not seekable" Nothing Nothing)
-ioe_notSeekable_notBin = ioException
- (IOError Nothing IllegalOperation ""
- "seek operations on text-mode handles are not allowed on this platform"
- Nothing Nothing)
-
-ioe_finalizedHandle :: FilePath -> Handle__
-ioe_finalizedHandle fp = throw
- (IOError Nothing IllegalOperation ""
- "handle is finalized" Nothing (Just fp))
-
-ioe_bufsiz :: Int -> IO a
-ioe_bufsiz n = ioException
- (IOError Nothing InvalidArgument "hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
- -- 9 => should be parens'ified.
-
--- -----------------------------------------------------------------------------
--- Handle Finalizers
-
--- For a duplex handle, we arrange that the read side points to the write side
--- (and hence keeps it alive if the read side is alive). This is done by
--- having the haOtherSide field of the read side point to the read side.
--- The finalizer is then placed on the write side, and the handle only gets
--- finalized once, when both sides are no longer required.
-
--- NOTE about finalized handles: It's possible that a handle can be
--- finalized and then we try to use it later, for example if the
--- handle is referenced from another finalizer, or from a thread that
--- has become unreferenced and then resurrected (arguably in the
--- latter case we shouldn't finalize the Handle...). Anyway,
--- we try to emit a helpful message which is better than nothing.
-
-stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
-stdHandleFinalizer fp m = do
- h_ <- takeMVar m
- flushWriteBufferOnly h_
- putMVar m (ioe_finalizedHandle fp)
-
-handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
-handleFinalizer fp m = do
- handle_ <- takeMVar m
- case haType handle_ of
- ClosedHandle -> return ()
- _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()
- -- ignore errors and async exceptions, and close the
- -- descriptor anyway...
- hClose_handle_ handle_
- return ()
- putMVar m (ioe_finalizedHandle fp)
-
--- ---------------------------------------------------------------------------
--- Grimy buffer operations
-
-checkBufferInvariants :: Handle__ -> IO ()
-#ifdef DEBUG
-checkBufferInvariants h_ = do
- let ref = haBuffer h_
- Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
- if not (
- size > 0
- && r <= w
- && w <= size
- && ( r /= w || (r == 0 && w == 0) )
- && ( state /= WriteBuffer || r == 0 )
- && ( state /= WriteBuffer || w < size ) -- write buffer is never full
- )
- then error "buffer invariant violation"
- else return ()
-#else
-checkBufferInvariants _ = return ()
-#endif
-
-newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
-newEmptyBuffer b state size
- = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
-
-allocateBuffer :: Int -> BufferState -> IO Buffer
-allocateBuffer sz@(I# size) state = IO $ \s ->
- -- We sometimes need to pass the address of this buffer to
- -- a "safe" foreign call, hence it must be immovable.
- case newPinnedByteArray# size s of { (# s', b #) ->
- (# s', newEmptyBuffer b state sz #) }
-
-writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
-writeCharIntoBuffer slab (I# off) (C# c)
- = IO $ \s -> case writeCharArray# slab off c s of
- s' -> (# s', I# (off +# 1#) #)
-
-readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
-readCharFromBuffer slab (I# off)
- = IO $ \s -> case readCharArray# slab off s of
- (# s', c #) -> (# s', (C# c, I# (off +# 1#)) #)
-
-getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
-getBuffer fd state = do
- buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
- ioref <- newIORef buffer
- is_tty <- fdIsTTY fd
-
- let buffer_mode
- | is_tty = LineBuffering
- | otherwise = BlockBuffering Nothing
-
- return (ioref, buffer_mode)
-
-mkUnBuffer :: IO (IORef Buffer)
-mkUnBuffer = do
- buffer <- allocateBuffer 1 ReadBuffer
- newIORef buffer
-
--- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
-flushWriteBufferOnly :: Handle__ -> IO ()
-flushWriteBufferOnly h_ = do
- let fd = haFD h_
- ref = haBuffer h_
- buf <- readIORef ref
- new_buf <- if bufferIsWritable buf
- then flushWriteBuffer fd (haIsStream h_) buf
- else return buf
- writeIORef ref new_buf
-
--- flushBuffer syncs the file with the buffer, including moving the
--- file pointer backwards in the case of a read buffer.
-flushBuffer :: Handle__ -> IO ()
-flushBuffer h_ = do
- let ref = haBuffer h_
- buf <- readIORef ref
-
- flushed_buf <-
- case bufState buf of
- ReadBuffer -> flushReadBuffer (haFD h_) buf
- WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
-
- writeIORef ref flushed_buf
-
--- When flushing a read buffer, we seek backwards by the number of
--- characters in the buffer. The file descriptor must therefore be
--- seekable: attempting to flush the read buffer on an unseekable
--- handle is not allowed.
-
-flushReadBuffer :: FD -> Buffer -> IO Buffer
-flushReadBuffer fd buf
- | bufferEmpty buf = return buf
- | otherwise = do
- let off = negate (bufWPtr buf - bufRPtr buf)
-# ifdef DEBUG_DUMP
- puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
-# endif
- throwErrnoIfMinus1Retry "flushReadBuffer"
- (c_lseek fd (fromIntegral off) sEEK_CUR)
- return buf{ bufWPtr=0, bufRPtr=0 }
-
-flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
-flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
- seq fd $ do -- strictness hack
- let bytes = w - r
-#ifdef DEBUG_DUMP
- puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
-#endif
- if bytes == 0
- then return (buf{ bufRPtr=0, bufWPtr=0 })
- else do
- res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
- (fromIntegral r) (fromIntegral bytes)
- let res' = fromIntegral res
- if res' < bytes
- then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
- else return buf{ bufRPtr=0, bufWPtr=0 }
-
-fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
-fillReadBuffer fd is_line is_stream
- buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
- -- buffer better be empty:
- assert (r == 0 && w == 0) $ do
- fillReadBufferLoop fd is_line is_stream buf b w size
-
--- For a line buffer, we just get the first chunk of data to arrive,
--- and don't wait for the whole buffer to be full (but we *do* wait
--- until some data arrives). This isn't really line buffering, but it
--- appears to be what GHC has done for a long time, and I suspect it
--- is more useful than line buffering in most cases.
-
-fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int
- -> IO Buffer
-fillReadBufferLoop fd is_line is_stream buf b w size = do
- let bytes = size - w
- if bytes == 0 -- buffer full?
- then return buf{ bufRPtr=0, bufWPtr=w }
- else do
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
-#endif
- res <- readRawBuffer "fillReadBuffer" fd is_stream b
- (fromIntegral w) (fromIntegral bytes)
- let res' = fromIntegral res
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
-#endif
- if res' == 0
- then if w == 0
- then ioe_EOF
- else return buf{ bufRPtr=0, bufWPtr=w }
- else if res' < bytes && not is_line
- then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
- else return buf{ bufRPtr=0, bufWPtr=w+res' }
-
-
-fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
-fillReadBufferWithoutBlocking fd is_stream
- buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
- -- buffer better be empty:
- assert (r == 0 && w == 0) $ do
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
-#endif
- res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
- 0 (fromIntegral size)
- let res' = fromIntegral res
-#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
-#endif
- return buf{ bufRPtr=0, bufWPtr=res' }
-
--- Low level routines for reading/writing to (raw)buffers:
-
-#ifndef mingw32_HOST_OS
-
-{-
-NOTE [nonblock]:
-
-Unix has broken semantics when it comes to non-blocking I/O: you can
-set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
-attached to the same underlying file, pipe or TTY; there's no way to
-have private non-blocking behaviour for an FD. See bug #724.
-
-We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
-come from external sources or are exposed externally are left in
-blocking mode. This solution has some problems though. We can't
-completely simulate a non-blocking read without O_NONBLOCK: several
-cases are wrong here. The cases that are wrong:
-
- * reading/writing to a blocking FD in non-threaded mode.
- In threaded mode, we just make a safe call to read().
- In non-threaded mode we call select() before attempting to read,
- but that leaves a small race window where the data can be read
- from the file descriptor before we issue our blocking read().
- * readRawBufferNoBlock for a blocking FD
-
-NOTE [2363]:
-
-In the threaded RTS we could just make safe calls to read()/write()
-for file descriptors in blocking mode without worrying about blocking
-other threads, but the problem with this is that the thread will be
-uninterruptible while it is blocked in the foreign call. See #2363.
-So now we always call fdReady() before reading, and if fdReady
-indicates that there's no data, we call threadWaitRead.
-
--}
-
-readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBuffer loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read -- unsafe is ok, it can't block
- | otherwise = do r <- throwErrnoIfMinus1 loc
- (unsafe_fdReady (fromIntegral fd) 0 0 0)
- if r /= 0
- then read
- else do threadWaitRead (fromIntegral fd); read
- where
- do_read call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitRead (fromIntegral fd))
- read = if threaded then safe_read else unsafe_read
- unsafe_read = do_read (read_rawBuffer fd buf off len)
- safe_read = do_read (safe_read_rawBuffer fd buf off len)
-
-readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtr loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read -- unsafe is ok, it can't block
- | otherwise = do r <- throwErrnoIfMinus1 loc
- (unsafe_fdReady (fromIntegral fd) 0 0 0)
- if r /= 0
- then read
- else do threadWaitRead (fromIntegral fd); read
- where
- do_read call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitRead (fromIntegral fd))
- read = if threaded then safe_read else unsafe_read
- unsafe_read = do_read (read_off fd buf off len)
- safe_read = do_read (safe_read_off fd buf off len)
-
-readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read -- unsafe is ok, it can't block
- | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
- if r /= 0 then safe_read
- else return 0
- -- XXX see note [nonblock]
- where
- do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
- unsafe_read = do_read (read_rawBuffer fd buf off len)
- safe_read = do_read (safe_read_rawBuffer fd buf off len)
-
-readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtrNoBlock loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read -- unsafe is ok, it can't block
- | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
- if r /= 0 then safe_read
- else return 0
- -- XXX see note [nonblock]
- where
- do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
- unsafe_read = do_read (read_off fd buf off len)
- safe_read = do_read (safe_read_off fd buf off len)
-
-writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-writeRawBuffer loc fd is_nonblock buf off len
- | is_nonblock = unsafe_write -- unsafe is ok, it can't block
- | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
- if r /= 0
- then write
- else do threadWaitWrite (fromIntegral fd); write
- where
- do_write call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitWrite (fromIntegral fd))
- write = if threaded then safe_write else unsafe_write
- unsafe_write = do_write (write_rawBuffer fd buf off len)
- safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)
-
-writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-writeRawBufferPtr loc fd is_nonblock buf off len
- | is_nonblock = unsafe_write -- unsafe is ok, it can't block
- | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
- if r /= 0
- then write
- else do threadWaitWrite (fromIntegral fd); write
- where
- do_write call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitWrite (fromIntegral fd))
- write = if threaded then safe_write else unsafe_write
- unsafe_write = do_write (write_off fd buf off len)
- safe_write = do_write (safe_write_off (fromIntegral fd) buf off len)
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "fdReady"
- unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
-
-#else /* mingw32_HOST_OS.... */
-
-readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBuffer loc fd is_stream buf off len
- | threaded = blockingReadRawBuffer loc fd is_stream buf off len
- | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
-
-readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtr loc fd is_stream buf off len
- | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
- | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
-
-writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-writeRawBuffer loc fd is_stream buf off len
- | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
- | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
-
-writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-writeRawBufferPtr loc fd is_stream buf off len
- | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
- | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len
-
--- ToDo: we don't have a non-blocking primitve read on Win32
-readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock = readRawBuffer
-
-readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtrNoBlock = readRawBufferPtr
--- Async versions of the read/write primitives, for the non-threaded RTS
-
-asyncReadRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt
- -> IO CInt
-asyncReadRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) off buf
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
-asyncReadRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt
- -> IO CInt
-asyncReadRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) (buf `plusPtr` off)
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
-asyncWriteRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt
- -> IO CInt
-asyncWriteRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) off buf
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
-asyncWriteRawBufferPtr :: String -> FD -> Bool -> CString -> Int -> CInt
- -> IO CInt
-asyncWriteRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0)
- (fromIntegral len) (buf `plusPtr` off)
- if l == (-1)
- then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
- else return (fromIntegral l)
-
--- Blocking versions of the read/write primitives, for the threaded RTS
-
-blockingReadRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt
- -> IO CInt
-blockingReadRawBuffer loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_recv_rawBuffer fd buf off len
-blockingReadRawBuffer loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_read_rawBuffer fd buf off len
-
-blockingReadRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt
- -> IO CInt
-blockingReadRawBufferPtr loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_recv_off fd buf off len
-blockingReadRawBufferPtr loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_read_off fd buf off len
-
-blockingWriteRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt
- -> IO CInt
-blockingWriteRawBuffer loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_send_rawBuffer fd buf off len
-blockingWriteRawBuffer loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_write_rawBuffer fd buf off len
-
-blockingWriteRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt
- -> IO CInt
-blockingWriteRawBufferPtr loc fd True buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_send_off fd buf off len
-blockingWriteRawBufferPtr loc fd False buf off len =
- throwErrnoIfMinus1Retry loc $
- safe_write_off fd buf off len
-
--- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
--- These calls may block, but that's ok.
-
-foreign import ccall safe "__hscore_PrelHandle_recv"
- safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_recv"
- safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_send"
- safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_send"
- safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
-#endif
-
-foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
-
-foreign import ccall safe "__hscore_PrelHandle_read"
- safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_read"
- safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_write"
- safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_write"
- safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
--- ---------------------------------------------------------------------------
--- Standard Handles
-
--- Three handles are allocated during program initialisation. The first
--- two manage input or output from the Haskell program's standard input
--- or output channel respectively. The third manages output to the
--- standard error channel. These handles are initially open.
-
-fd_stdin, fd_stdout, fd_stderr :: FD
-fd_stdin = 0
-fd_stdout = 1
-fd_stderr = 2
-
--- | A handle managing input from the Haskell program's standard input channel.
-stdin :: Handle
-stdin = unsafePerformIO $ do
- -- ToDo: acquire lock
- -- We don't set non-blocking mode on standard handles, because it may
- -- confuse other applications attached to the same TTY/pipe
- -- see Note [nonblock]
- (buf, bmode) <- getBuffer fd_stdin ReadBuffer
- mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
-
--- | A handle managing output to the Haskell program's standard output channel.
-stdout :: Handle
-stdout = unsafePerformIO $ do
- -- ToDo: acquire lock
- -- We don't set non-blocking mode on standard handles, because it may
- -- confuse other applications attached to the same TTY/pipe
- -- see Note [nonblock]
- (buf, bmode) <- getBuffer fd_stdout WriteBuffer
- mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
-
--- | A handle managing output to the Haskell program's standard error channel.
-stderr :: Handle
-stderr = unsafePerformIO $ do
- -- ToDo: acquire lock
- -- We don't set non-blocking mode on standard handles, because it may
- -- confuse other applications attached to the same TTY/pipe
- -- see Note [nonblock]
- buf <- mkUnBuffer
- mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
-
--- ---------------------------------------------------------------------------
--- Opening and Closing Files
-
-addFilePathToIOError :: String -> FilePath -> IOException -> IOException
-addFilePathToIOError fun fp ioe
- = ioe{ ioe_location = fun, ioe_filename = Just fp }
-
--- | Computation 'openFile' @file mode@ allocates and returns a new, open
--- handle to manage the file @file@. It manages input if @mode@
--- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
--- and both input and output if mode is 'ReadWriteMode'.
---
--- If the file does not exist and it is opened for output, it should be
--- created as a new file. If @mode@ is 'WriteMode' and the file
--- already exists, then it should be truncated to zero length.
--- Some operating systems delete empty files, so there is no guarantee
--- that the file will exist following an 'openFile' with @mode@
--- 'WriteMode' unless it is subsequently written to successfully.
--- The handle is positioned at the end of the file if @mode@ is
--- 'AppendMode', and otherwise at the beginning (in which case its
--- internal position is 0).
--- The initial buffer mode is implementation-dependent.
---
--- This operation may fail with:
---
--- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
---
--- * 'isDoesNotExistError' if the file does not exist; or
---
--- * 'isPermissionError' if the user does not have permission to open the file.
---
--- Note: if you will be working with files containing binary data, you'll want to
--- be using 'openBinaryFile'.
-openFile :: FilePath -> IOMode -> IO Handle
-openFile fp im =
- catch
- (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
- (\e -> ioError (addFilePathToIOError "openFile" fp e))
-
--- | Like 'openFile', but open the file in binary mode.
--- On Windows, reading a file in text mode (which is the default)
--- will translate CRLF to LF, and writing will translate LF to CRLF.
--- This is usually what you want with text files. With binary files
--- this is undesirable; also, as usual under Microsoft operating systems,
--- text mode treats control-Z as EOF. Binary mode turns off all special
--- treatment of end-of-line and end-of-file characters.
--- (See also 'hSetBinaryMode'.)
-
-openBinaryFile :: FilePath -> IOMode -> IO Handle
-openBinaryFile fp m =
- catch
- (openFile' fp m True)
- (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
-
-openFile' :: String -> IOMode -> Bool -> IO Handle
-openFile' filepath mode binary =
- withCString filepath $ \ f ->
-
- let
- oflags1 = case mode of
- ReadMode -> read_flags
-#ifdef mingw32_HOST_OS
- WriteMode -> write_flags .|. o_TRUNC
-#else
- WriteMode -> write_flags
-#endif
- ReadWriteMode -> rw_flags
- AppendMode -> append_flags
-
- binary_flags
- | binary = o_BINARY
- | otherwise = 0
-
- oflags = oflags1 .|. binary_flags
- in do
-
- -- the old implementation had a complicated series of three opens,
- -- which is perhaps because we have to be careful not to open
- -- directories. However, the man pages I've read say that open()
- -- always returns EISDIR if the file is a directory and was opened
- -- for writing, so I think we're ok with a single open() here...
- fd <- throwErrnoIfMinus1Retry "openFile"
- (c_open f (fromIntegral oflags) 0o666)
-
- stat@(fd_type,_,_) <- fdStat fd
-
- h <- fdToHandle_stat fd (Just stat)
- False -- set_non_blocking
- True -- is_non_blocking
- False -- is_socket
- filepath mode binary
- `catchAny` \e -> do c_close fd; throw e
- -- NB. don't forget to close the FD if fdToHandle' fails, otherwise
- -- this FD leaks.
- -- ASSERT: if we just created the file, then fdToHandle' won't fail
- -- (so we don't need to worry about removing the newly created file
- -- in the event of an error).
-
-#ifndef mingw32_HOST_OS
- -- we want to truncate() if this is an open in WriteMode, but only
- -- if the target is a RegularFile. ftruncate() fails on special files
- -- like /dev/null.
- if mode == WriteMode && fd_type == RegularFile
- then throwErrnoIf (/=0) "openFile"
- (c_ftruncate fd 0)
- else return 0
-#endif
- return h
-
-
-std_flags, output_flags, read_flags, write_flags, rw_flags,
- append_flags :: CInt
-std_flags = o_NONBLOCK .|. o_NOCTTY
-output_flags = std_flags .|. o_CREAT
-read_flags = std_flags .|. o_RDONLY
-write_flags = output_flags .|. o_WRONLY
-rw_flags = output_flags .|. o_RDWR
-append_flags = write_flags .|. o_APPEND
-
--- ---------------------------------------------------------------------------
--- fdToHandle
-
-fdToHandle_stat :: FD
- -> Maybe (FDType, CDev, CIno)
- -> Bool -- set_non_blocking
- -> Bool -- is_non_blocking
- -> Bool -- is_socket
- -> FilePath
- -> IOMode
- -> Bool
- -> IO Handle
-
-fdToHandle_stat fd mb_stat set_non_blocking is_non_blocking is_socket
- filepath mode binary = do
-
-#ifdef mingw32_HOST_OS
- -- On Windows, the is_stream flag indicates that the Handle is a socket
- let is_stream = is_socket
-#else
- when set_non_blocking $ setNonBlockingFD fd
- -- turn on non-blocking mode
-
- -- On Unix, the is_stream flag indicates that the FD is in non-blocking mode
- let is_stream = is_non_blocking || set_non_blocking
-#endif
-
- let (ha_type, write) =
- case mode of
- ReadMode -> ( ReadHandle, False )
- WriteMode -> ( WriteHandle, True )
- ReadWriteMode -> ( ReadWriteHandle, True )
- AppendMode -> ( AppendHandle, True )
-
- -- open() won't tell us if it was a directory if we only opened for
- -- reading, so check again.
- (fd_type,dev,ino) <-
- case mb_stat of
- Just x -> return x
- Nothing -> fdStat fd
-
- case fd_type of
- Directory ->
- ioException (IOError Nothing InappropriateType "openFile"
- "is a directory" Nothing Nothing)
-
- -- regular files need to be locked
- RegularFile -> do
-#ifndef mingw32_HOST_OS
- -- On Windows we use explicit exclusion via sopen() to implement
- -- this locking (see __hscore_open()); on Unix we have to
- -- implment it in the RTS.
- r <- lockFile fd dev ino (fromBool write)
- when (r == -1) $
- ioException (IOError Nothing ResourceBusy "openFile"
- "file is locked" Nothing Nothing)
-#endif
- mkFileHandle fd is_stream filepath ha_type binary
-
- Stream
- -- only *Streams* can be DuplexHandles. Other read/write
- -- Handles must share a buffer.
- | ReadWriteHandle <- ha_type ->
- mkDuplexHandle fd is_stream filepath binary
- | otherwise ->
- mkFileHandle fd is_stream filepath ha_type binary
-
- RawDevice ->
- mkFileHandle fd is_stream filepath ha_type binary
-
--- | Old API kept to avoid breaking clients
-fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool
- -> IO Handle
-fdToHandle' fd mb_type is_socket filepath mode binary
- = do
- let mb_stat = case mb_type of
- Nothing -> Nothing
- -- fdToHandle_stat will do the stat:
- Just RegularFile -> Nothing
- -- no stat required for streams etc.:
- Just other -> Just (other,0,0)
- fdToHandle_stat fd mb_stat
- is_socket -- set_non_blocking
- False -- is_non_blocking
- is_socket -- is_socket
- filepath mode binary
-
-fdToHandle :: FD -> IO Handle
-fdToHandle fd = do
- mode <- fdGetMode fd
- let fd_str = "<file descriptor: " ++ show fd ++ ">"
- fdToHandle_stat fd Nothing
- False -- set_non_blocking
- False -- is_non_blocking
- False -- is_socket (guess XXX)
- fd_str mode True{-bin mode-}
-
-#ifndef mingw32_HOST_OS
-foreign import ccall unsafe "lockFile"
- lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
-
-foreign import ccall unsafe "unlockFile"
- unlockFile :: CInt -> IO CInt
-#endif
-
-mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
- -> IO Handle
-mkStdHandle fd filepath ha_type buf bmode = do
- spares <- newIORef BufferListNil
- newFileHandle filepath (stdHandleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haIsStream = False, -- means FD is blocking on Unix
- haBufferMode = bmode,
- haBuffer = buf,
- haBuffers = spares,
- haOtherSide = Nothing
- })
-
-mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
-mkFileHandle fd is_stream filepath ha_type binary = do
- (buf, bmode) <- getBuffer fd (initBufferState ha_type)
-
-#ifdef mingw32_HOST_OS
- -- On Windows, if this is a read/write handle and we are in text mode,
- -- turn off buffering. We don't correctly handle the case of switching
- -- from read mode to write mode on a buffered text-mode handle, see bug
- -- \#679.
- bmode2 <- case ha_type of
- ReadWriteHandle | not binary -> return NoBuffering
- _other -> return bmode
-#else
- let bmode2 = bmode
-#endif
-
- spares <- newIORef BufferListNil
- newFileHandle filepath (handleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
- haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = bmode2,
- haBuffer = buf,
- haBuffers = spares,
- haOtherSide = Nothing
- })
-
-mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
-mkDuplexHandle fd is_stream filepath binary = do
- (w_buf, w_bmode) <- getBuffer fd WriteBuffer
- w_spares <- newIORef BufferListNil
- let w_handle_ =
- Handle__ { haFD = fd,
- haType = WriteHandle,
- haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = w_bmode,
- haBuffer = w_buf,
- haBuffers = w_spares,
- haOtherSide = Nothing
- }
- write_side <- newMVar w_handle_
-
- (r_buf, r_bmode) <- getBuffer fd ReadBuffer
- r_spares <- newIORef BufferListNil
- let r_handle_ =
- Handle__ { haFD = fd,
- haType = ReadHandle,
- haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = r_bmode,
- haBuffer = r_buf,
- haBuffers = r_spares,
- haOtherSide = Just write_side
- }
- read_side <- newMVar r_handle_
-
- addMVarFinalizer write_side (handleFinalizer filepath write_side)
- return (DuplexHandle filepath read_side write_side)
-
-initBufferState :: HandleType -> BufferState
-initBufferState ReadHandle = ReadBuffer
-initBufferState _ = WriteBuffer
-
--- ---------------------------------------------------------------------------
--- Closing a handle
-
--- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
--- computation finishes, if @hdl@ is writable its buffer is flushed as
--- for 'hFlush'.
--- Performing 'hClose' on a handle that has already been closed has no effect;
--- doing so is not an error. All other operations on a closed handle will fail.
--- If 'hClose' fails for any reason, any further operations (apart from
--- 'hClose') on the handle will still fail as if @hdl@ had been successfully
--- closed.
-
-hClose :: Handle -> IO ()
-hClose h@(FileHandle _ m) = do
- mb_exc <- hClose' h m
- case mb_exc of
- Nothing -> return ()
- Just e -> throwIO e
-hClose h@(DuplexHandle _ r w) = do
- mb_exc1 <- hClose' h w
- mb_exc2 <- hClose' h r
- case (do mb_exc1; mb_exc2) of
- Nothing -> return ()
- Just e -> throwIO e
-
-hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
-hClose' h m = withHandle' "hClose" h m $ hClose_help
-
--- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
--- or an IO error occurs on a lazy stream. The semi-closed Handle is
--- then closed immediately. We have to be careful with DuplexHandles
--- though: we have to leave the closing to the finalizer in that case,
--- because the write side may still be in use.
-hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
-hClose_help handle_ =
- case haType handle_ of
- ClosedHandle -> return (handle_,Nothing)
- _ -> do flushWriteBufferOnly handle_ -- interruptible
- hClose_handle_ handle_
-
-hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
-hClose_handle_ handle_ = do
- let fd = haFD handle_
-
- -- close the file descriptor, but not when this is the read
- -- side of a duplex handle.
- -- If an exception is raised by the close(), we want to continue
- -- to close the handle and release the lock if it has one, then
- -- we return the exception to the caller of hClose_help which can
- -- raise it if necessary.
- maybe_exception <-
- case haOtherSide handle_ of
- Nothing -> (do
- throwErrnoIfMinus1Retry_ "hClose"
-#ifdef mingw32_HOST_OS
- (closeFd (haIsStream handle_) fd)
-#else
- (c_close fd)
-#endif
- return Nothing
- )
- `catchException` \e -> return (Just e)
-
- Just _ -> return Nothing
-
- -- free the spare buffers
- writeIORef (haBuffers handle_) BufferListNil
- writeIORef (haBuffer handle_) noBuffer
-
-#ifndef mingw32_HOST_OS
- -- unlock it
- unlockFile fd
-#endif
-
- -- we must set the fd to -1, because the finalizer is going
- -- to run eventually and try to close/unlock it.
- return (handle_{ haFD = -1,
- haType = ClosedHandle
- },
- maybe_exception)
-
-{-# NOINLINE noBuffer #-}
-noBuffer :: Buffer
-noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-
------------------------------------------------------------------------------
--- Detecting and changing the size of a file
-
--- | For a handle @hdl@ which attached to a physical file,
--- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
-
-hFileSize :: Handle -> IO Integer
-hFileSize handle =
- withHandle_ "hFileSize" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- _ -> do flushWriteBufferOnly handle_
- r <- fdFileSize (haFD handle_)
- if r /= -1
- then return r
- else ioException (IOError Nothing InappropriateType "hFileSize"
- "not a regular file" Nothing Nothing)
-
-
--- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
-
-hSetFileSize :: Handle -> Integer -> IO ()
-hSetFileSize handle size =
- withHandle_ "hSetFileSize" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- _ -> do flushWriteBufferOnly handle_
- throwErrnoIf (/=0) "hSetFileSize"
- (c_ftruncate (haFD handle_) (fromIntegral size))
- return ()
-
--- ---------------------------------------------------------------------------
--- Detecting the End of Input
-
--- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
--- 'True' if no further input can be taken from @hdl@ or for a
--- physical file, if the current I\/O position is equal to the length of
--- the file. Otherwise, it returns 'False'.
---
--- NOTE: 'hIsEOF' may block, because it is the same as calling
--- 'hLookAhead' and checking for an EOF exception.
-
-hIsEOF :: Handle -> IO Bool
-hIsEOF handle =
- catch
- (do hLookAhead handle; return False)
- (\e -> if isEOFError e then return True else ioError e)
-
--- | The computation 'isEOF' is identical to 'hIsEOF',
--- except that it works only on 'stdin'.
-
-isEOF :: IO Bool
-isEOF = hIsEOF stdin
-
--- ---------------------------------------------------------------------------
--- Looking ahead
-
--- | Computation 'hLookAhead' returns the next character from the handle
--- without removing it from the input buffer, blocking until a character
--- is available.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
-
-hLookAhead :: Handle -> IO Char
-hLookAhead handle =
- wantReadableHandle "hLookAhead" handle hLookAhead'
-
-hLookAhead' :: Handle__ -> IO Char
-hLookAhead' handle_ = do
- let ref = haBuffer handle_
- fd = haFD handle_
- buf <- readIORef ref
-
- -- fill up the read buffer if necessary
- new_buf <- if bufferEmpty buf
- then fillReadBuffer fd True (haIsStream handle_) buf
- else return buf
-
- writeIORef ref new_buf
-
- (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
- return c
-
--- ---------------------------------------------------------------------------
--- Buffering Operations
-
--- Three kinds of buffering are supported: line-buffering,
--- block-buffering or no-buffering. See GHC.IOBase for definition and
--- further explanation of what the type represent.
-
--- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
--- handle @hdl@ on subsequent reads and writes.
---
--- If the buffer mode is changed from 'BlockBuffering' or
--- 'LineBuffering' to 'NoBuffering', then
---
--- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
---
--- * if @hdl@ is not writable, the contents of the buffer is discarded.
---
--- This operation may fail with:
---
--- * 'isPermissionError' if the handle has already been used for reading
--- or writing and the implementation does not allow the buffering mode
--- to be changed.
-
-hSetBuffering :: Handle -> BufferMode -> IO ()
-hSetBuffering handle mode =
- withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> do
- {- Note:
- - we flush the old buffer regardless of whether
- the new buffer could fit the contents of the old buffer
- or not.
- - allow a handle's buffering to change even if IO has
- occurred (ANSI C spec. does not allow this, nor did
- the previous implementation of IO.hSetBuffering).
- - a non-standard extension is to allow the buffering
- of semi-closed handles to change [sof 6/98]
- -}
- flushBuffer handle_
-
- let state = initBufferState (haType handle_)
- new_buf <-
- case mode of
- -- we always have a 1-character read buffer for
- -- unbuffered handles: it's needed to
- -- support hLookAhead.
- NoBuffering -> allocateBuffer 1 ReadBuffer
- LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
- BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
- BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
- | otherwise -> allocateBuffer n state
- writeIORef (haBuffer handle_) new_buf
-
- -- for input terminals we need to put the terminal into
- -- cooked or raw mode depending on the type of buffering.
- is_tty <- fdIsTTY (haFD handle_)
- when (is_tty && isReadableHandleType (haType handle_)) $
- case mode of
-#ifndef mingw32_HOST_OS
- -- 'raw' mode under win32 is a bit too specialised (and troublesome
- -- for most common uses), so simply disable its use here.
- NoBuffering -> setCooked (haFD handle_) False
-#else
- NoBuffering -> return ()
-#endif
- _ -> setCooked (haFD handle_) True
-
- -- throw away spare buffers, they might be the wrong size
- writeIORef (haBuffers handle_) BufferListNil
-
- return (handle_{ haBufferMode = mode })
-
--- -----------------------------------------------------------------------------
--- hFlush
-
--- | The action 'hFlush' @hdl@ causes any items buffered for output
--- in handle @hdl@ to be sent immediately to the operating system.
---
--- This operation may fail with:
---
--- * 'isFullError' if the device is full;
---
--- * 'isPermissionError' if a system resource limit would be exceeded.
--- It is unspecified whether the characters in the buffer are discarded
--- or retained under these circumstances.
-
-hFlush :: Handle -> IO ()
-hFlush handle =
- wantWritableHandle "hFlush" handle $ \ handle_ -> do
- buf <- readIORef (haBuffer handle_)
- if bufferIsWritable buf && not (bufferEmpty buf)
- then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
- writeIORef (haBuffer handle_) flushed_buf
- else return ()
-
-
--- -----------------------------------------------------------------------------
--- Repositioning Handles
-
-data HandlePosn = HandlePosn Handle HandlePosition
-
-instance Eq HandlePosn where
- (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
-
-instance Show HandlePosn where
- showsPrec p (HandlePosn h pos) =
- showsPrec p h . showString " at position " . shows pos
-
- -- HandlePosition is the Haskell equivalent of POSIX' off_t.
- -- We represent it as an Integer on the Haskell side, but
- -- cheat slightly in that hGetPosn calls upon a C helper
- -- that reports the position back via (merely) an Int.
-type HandlePosition = Integer
-
--- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
--- @hdl@ as a value of the abstract type 'HandlePosn'.
-
-hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle = do
- posn <- hTell handle
- return (HandlePosn handle posn)
-
--- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
--- then computation 'hSetPosn' @p@ sets the position of @hdl@
--- to the position it held at the time of the call to 'hGetPosn'.
---
--- This operation may fail with:
---
--- * 'isPermissionError' if a system resource limit would be exceeded.
-
-hSetPosn :: HandlePosn -> IO ()
-hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
-
--- ---------------------------------------------------------------------------
--- hSeek
-
--- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
-data SeekMode
- = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
- | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
- -- from the current position.
- | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
- -- from the end of the file.
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-
-{- Note:
- - when seeking using `SeekFromEnd', positive offsets (>=0) means
- seeking at or past EOF.
-
- - we possibly deviate from the report on the issue of seeking within
- the buffer and whether to flush it or not. The report isn't exactly
- clear here.
--}
-
--- | Computation 'hSeek' @hdl mode i@ sets the position of handle
--- @hdl@ depending on @mode@.
--- The offset @i@ is given in terms of 8-bit bytes.
---
--- If @hdl@ is block- or line-buffered, then seeking to a position which is not
--- in the current buffer will first cause any items in the output buffer to be
--- written to the device, and then cause the input buffer to be discarded.
--- Some handles may not be seekable (see 'hIsSeekable'), or only support a
--- subset of the possible positioning operations (for instance, it may only
--- be possible to seek to the end of a tape, or to a positive offset from
--- the beginning or current position).
--- It is not possible to set a negative I\/O position, or for
--- a physical file, an I\/O position beyond the current end-of-file.
---
--- This operation may fail with:
---
--- * 'isPermissionError' if a system resource limit would be exceeded.
-
-hSeek :: Handle -> SeekMode -> Integer -> IO ()
-hSeek handle mode offset =
- wantSeekableHandle "hSeek" handle $ \ handle_ -> do
-# ifdef DEBUG_DUMP
- puts ("hSeek " ++ show (mode,offset) ++ "\n")
-# endif
- let ref = haBuffer handle_
- buf <- readIORef ref
- let r = bufRPtr buf
- w = bufWPtr buf
- fd = haFD handle_
-
- let do_seek =
- throwErrnoIfMinus1Retry_ "hSeek"
- (c_lseek (haFD handle_) (fromIntegral offset) whence)
-
- whence :: CInt
- whence = case mode of
- AbsoluteSeek -> sEEK_SET
- RelativeSeek -> sEEK_CUR
- SeekFromEnd -> sEEK_END
-
- if bufferIsWritable buf
- then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
- writeIORef ref new_buf
- do_seek
- else do
-
- if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
- then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
- else do
-
- new_buf <- flushReadBuffer (haFD handle_) buf
- writeIORef ref new_buf
- do_seek
-
-
-hTell :: Handle -> IO Integer
-hTell handle =
- wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
-
-#if defined(mingw32_HOST_OS)
- -- urgh, on Windows we have to worry about \n -> \r\n translation,
- -- so we can't easily calculate the file position using the
- -- current buffer size. Just flush instead.
- flushBuffer handle_
-#endif
- let fd = haFD handle_
- posn <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "hGetPosn"
- (c_lseek fd 0 sEEK_CUR)
-
- let ref = haBuffer handle_
- buf <- readIORef ref
-
- let real_posn
- | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
- | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
-# ifdef DEBUG_DUMP
- puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
- puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
-# endif
- return real_posn
-
--- -----------------------------------------------------------------------------
--- Handle Properties
-
--- A number of operations return information about the properties of a
--- handle. Each of these operations returns `True' if the handle has
--- the specified property, and `False' otherwise.
-
-hIsOpen :: Handle -> IO Bool
-hIsOpen handle =
- withHandle_ "hIsOpen" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> return False
- SemiClosedHandle -> return False
- _ -> return True
-
-hIsClosed :: Handle -> IO Bool
-hIsClosed handle =
- withHandle_ "hIsClosed" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> return True
- _ -> return False
-
-{- not defined, nor exported, but mentioned
- here for documentation purposes:
-
- hSemiClosed :: Handle -> IO Bool
- hSemiClosed h = do
- ho <- hIsOpen h
- hc <- hIsClosed h
- return (not (ho || hc))
--}
-
-hIsReadable :: Handle -> IO Bool
-hIsReadable (DuplexHandle _ _ _) = return True
-hIsReadable handle =
- withHandle_ "hIsReadable" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isReadableHandleType htype)
-
-hIsWritable :: Handle -> IO Bool
-hIsWritable (DuplexHandle _ _ _) = return True
-hIsWritable handle =
- withHandle_ "hIsWritable" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isWritableHandleType htype)
-
--- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
--- for @hdl@.
-
-hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering handle =
- withHandle_ "hGetBuffering" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ ->
- -- We're being non-standard here, and allow the buffering
- -- of a semi-closed handle to be queried. -- sof 6/98
- return (haBufferMode handle_) -- could be stricter..
-
-hIsSeekable :: Handle -> IO Bool
-hIsSeekable handle =
- withHandle_ "hIsSeekable" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> return False
- _ -> do t <- fdType (haFD handle_)
- return ((t == RegularFile || t == RawDevice)
- && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
-
--- -----------------------------------------------------------------------------
--- Changing echo status (Non-standard GHC extensions)
-
--- | Set the echoing status of a handle connected to a terminal.
-
-hSetEcho :: Handle -> Bool -> IO ()
-hSetEcho handle on = do
- isT <- hIsTerminalDevice handle
- if not isT
- then return ()
- else
- withHandle_ "hSetEcho" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> setEcho (haFD handle_) on
-
--- | Get the echoing status of a handle connected to a terminal.
-
-hGetEcho :: Handle -> IO Bool
-hGetEcho handle = do
- isT <- hIsTerminalDevice handle
- if not isT
- then return False
- else
- withHandle_ "hGetEcho" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> getEcho (haFD handle_)
-
--- | Is the handle connected to a terminal?
-
-hIsTerminalDevice :: Handle -> IO Bool
-hIsTerminalDevice handle = do
- withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> fdIsTTY (haFD handle_)
-
--- -----------------------------------------------------------------------------
--- hSetBinaryMode
-
--- | Select binary mode ('True') or text mode ('False') on a open handle.
--- (See also 'openBinaryFile'.)
-
-hSetBinaryMode :: Handle -> Bool -> IO ()
-hSetBinaryMode handle bin =
- withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
- do throwErrnoIfMinus1_ "hSetBinaryMode"
- (setmode (haFD handle_) bin)
- return handle_{haIsBin=bin}
-
-foreign import ccall unsafe "__hscore_setmode"
- setmode :: CInt -> Bool -> IO CInt
-
--- -----------------------------------------------------------------------------
--- Duplicating a Handle
-
--- | Returns a duplicate of the original handle, with its own buffer.
--- The two Handles will share a file pointer, however. The original
--- handle's buffer is flushed, including discarding any input data,
--- before the handle is duplicated.
-
-hDuplicate :: Handle -> IO Handle
-hDuplicate h@(FileHandle path m) = do
- new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
- newFileHandle path (handleFinalizer path) new_h_
-hDuplicate h@(DuplexHandle path r w) = do
- new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
- new_w <- newMVar new_w_
- new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
- new_r <- newMVar new_r_
- addMVarFinalizer new_w (handleFinalizer path new_w)
- return (DuplexHandle path new_r new_w)
-
-dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
- -> IO (Handle__, Handle__)
-dupHandle h other_side h_ = do
- -- flush the buffer first, so we don't have to copy its contents
- flushBuffer h_
- new_fd <- case other_side of
- Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
- Just r -> withHandle_' "dupHandle" h r (return . haFD)
- dupHandle_ other_side h_ new_fd
-
-dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__
- -> IO (Handle__, Handle__)
-dupHandleTo other_side hto_ h_ = do
- flushBuffer h_
- -- Windows' dup2 does not return the new descriptor, unlike Unix
- throwErrnoIfMinus1 "dupHandleTo" $
- c_dup2 (haFD h_) (haFD hto_)
- dupHandle_ other_side h_ (haFD hto_)
-
-dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
- -> IO (Handle__, Handle__)
-dupHandle_ other_side h_ new_fd = do
- buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
- ioref <- newIORef buffer
- ioref_buffers <- newIORef BufferListNil
-
- let new_handle_ = h_{ haFD = new_fd,
- haBuffer = ioref,
- haBuffers = ioref_buffers,
- haOtherSide = other_side }
- return (h_, new_handle_)
-
--- -----------------------------------------------------------------------------
--- Replacing a Handle
-
-{- |
-Makes the second handle a duplicate of the first handle. The second
-handle will be closed first, if it is not already.
-
-This can be used to retarget the standard Handles, for example:
-
-> do h <- openFile "mystdout" WriteMode
-> hDuplicateTo h stdout
--}
-
-hDuplicateTo :: Handle -> Handle -> IO ()
-hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
- withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
- _ <- hClose_help h2_
- withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
-hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
- withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
- _ <- hClose_help w2_
- withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
- withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
- _ <- hClose_help r2_
- withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
-hDuplicateTo h1 _ =
- ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
- "handles are incompatible" Nothing Nothing)
-
--- ---------------------------------------------------------------------------
--- showing Handles.
---
--- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
--- than the (pure) instance of 'Show' for 'Handle'.
-
-hShow :: Handle -> IO String
-hShow h@(FileHandle path _) = showHandle' path False h
-hShow h@(DuplexHandle path _ _) = showHandle' path True h
-
-showHandle' :: String -> Bool -> Handle -> IO String
-showHandle' filepath is_duplex h =
- withHandle_ "showHandle" h $ \hdl_ ->
- let
- showType | is_duplex = showString "duplex (read-write)"
- | otherwise = shows (haType hdl_)
- in
- return
- (( showChar '{' .
- showHdl (haType hdl_)
- (showString "loc=" . showString filepath . showChar ',' .
- showString "type=" . showType . showChar ',' .
- showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
- showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
- ) "")
- where
-
- showHdl :: HandleType -> ShowS -> ShowS
- showHdl ht cont =
- case ht of
- ClosedHandle -> shows ht . showString "}"
- _ -> cont
-
- showBufMode :: Buffer -> BufferMode -> ShowS
- showBufMode buf bmo =
- case bmo of
- NoBuffering -> showString "none"
- LineBuffering -> showString "line"
- BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
- BlockBuffering Nothing -> showString "block " . showParen True (shows def)
- where
- def :: Int
- def = bufSize buf
-
--- ---------------------------------------------------------------------------
--- debugging
-
-#if defined(DEBUG_DUMP)
-puts :: String -> IO ()
-puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
- return ()
-#endif
-
--- -----------------------------------------------------------------------------
--- utils
-
-throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
-throwErrnoIfMinus1RetryOnBlock loc f on_block =
- do
- res <- f
- if (res :: CInt) == -1
- then do
- err <- getErrno
- if err == eINTR
- then throwErrnoIfMinus1RetryOnBlock loc f on_block
- else if err == eWOULDBLOCK || err == eAGAIN
- then do on_block
- else throwErrno loc
- else return res
-
--- -----------------------------------------------------------------------------
--- wrappers to platform-specific constants:
-
-foreign import ccall unsafe "__hscore_supportsTextMode"
- tEXT_MODE_SEEK_ALLOWED :: Bool
-
-foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
-foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
-foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
-foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
+import GHC.IO.IOMode
+import GHC.IO.Handle
+import GHC.IO.Handle.Internals
+import GHC.IO.Handle.FD
+++ /dev/null
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
-
-module GHC.Handle where
-
-import GHC.IOBase
-
-stdout :: Handle
-stderr :: Handle
-hFlush :: Handle -> IO ()
-{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
{-# OPTIONS_HADDOCK hide #-}
-
-#undef DEBUG_DUMP
-
-----------------------------------------------------------------------------
-- |
-- Module : GHC.IO
--- Copyright : (c) The University of Glasgow, 1992-2001
+-- Copyright : (c) The University of Glasgow 1994-2002
-- License : see libraries/base/LICENSE
--
--- Maintainer : libraries@haskell.org
+-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
--- Portability : non-portable
+-- Portability : non-portable (GHC Extensions)
--
--- String I\/O functions
+-- Definitions for the 'IO' monad and its friends.
--
-----------------------------------------------------------------------------
-- #hide
-module GHC.IO (
- hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
- commitBuffer', -- hack, see below
- hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
- hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
- memcpy_ba_baoff,
- memcpy_ptr_baoff,
- memcpy_baoff_ba,
- memcpy_baoff_ptr,
- ) where
-
-import Foreign
-import Foreign.C
-
-import System.IO.Error
-import Data.Maybe
-import Control.Monad
-#ifndef mingw32_HOST_OS
-import System.Posix.Internals
-#endif
+module GHC.IO (
+ IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO,
+ unsafePerformIO, unsafeInterleaveIO,
+ unsafeDupablePerformIO, unsafeDupableInterleaveIO,
+ noDuplicate,
+
+ -- To and from from ST
+ stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
+
+ FilePath,
+
+ catchException, catchAny, throwIO,
+ block, unblock, blocked,
+ onException, finally, evaluate
+ ) where
-import GHC.Enum
import GHC.Base
-import GHC.IOBase
-import GHC.Handle -- much of the real stuff is in here
-import GHC.Real
-import GHC.Num
-import GHC.Show
-import GHC.List
+import GHC.ST
+import GHC.Exception
+import Data.Maybe
-#ifdef mingw32_HOST_OS
-import GHC.Conc
-#endif
+import {-# SOURCE #-} GHC.IO.Exception ( userError )
-- ---------------------------------------------------------------------------
--- Simple input operations
+-- The IO Monad
--- 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.
+{-
+The IO Monad is just an instance of the ST monad, where the state is
+the real world. We use the exception mechanism (in GHC.Exception) to
+implement IO exceptions.
--- | Computation 'hWaitForInput' @hdl t@
--- waits until input is available on handle @hdl@.
--- It returns 'True' as soon as input is available on @hdl@,
--- or 'False' if no input is available within @t@ milliseconds.
---
--- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
---
--- NOTE for GHC users: unless you use the @-threaded@ flag,
--- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
--- threads for the duration of the call. It behaves like a
--- @safe@ foreign call in this respect.
-
-hWaitForInput :: Handle -> Int -> IO Bool
-hWaitForInput h msecs = do
- wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
-
- if not (bufferEmpty buf)
- then return True
- else do
-
- if msecs < 0
- then do buf' <- fillReadBuffer (haFD handle_) True
- (haIsStream handle_) buf
- writeIORef ref buf'
- return True
- else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
- fdReady (haFD handle_) 0 {- read -}
- (fromIntegral msecs)
- (fromIntegral $ fromEnum $ haIsStream handle_)
- if r /= 0 then do -- Call hLookAhead' to throw an EOF
- -- exception if appropriate
- hLookAhead' handle_
- return True
- else return False
-
-foreign import ccall safe "fdReady"
- fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+NOTE: The IO representation is deeply wired in to various parts of the
+system. The following list may or may not be exhaustive:
--- ---------------------------------------------------------------------------
--- hGetChar
+Compiler - types of various primitives in PrimOp.lhs
--- | Computation 'hGetChar' @hdl@ reads a character from the file or
--- channel managed by @hdl@, blocking until a character is available.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
-
-hGetChar :: Handle -> IO Char
-hGetChar handle =
- wantReadableHandle "hGetChar" handle $ \handle_ -> do
-
- let fd = haFD handle_
- ref = haBuffer handle_
-
- buf <- readIORef ref
- if not (bufferEmpty buf)
- then hGetcBuffered fd ref buf
- else do
-
- -- buffer is empty.
- case haBufferMode handle_ of
- LineBuffering -> do
- new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
- hGetcBuffered fd ref new_buf
- BlockBuffering _ -> do
- new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
- -- ^^^^
- -- don't wait for a completely full buffer.
- hGetcBuffered fd ref new_buf
- NoBuffering -> do
- -- make use of the minimal buffer we already have
- let !raw = bufBuf buf
- r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1
- if r == 0
- then ioe_EOF
- else do (c,_) <- readCharFromBuffer raw 0
- return c
-
-hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char
-hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w }
- = do (c, r) <- readCharFromBuffer b r0
- let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
- | otherwise = buf{ bufRPtr=r }
- writeIORef ref new_buf
- return c
+RTS - forceIO (StgMiscClosures.hc)
+ - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
+ (Exceptions.hc)
+ - raiseAsync (Schedule.c)
--- ---------------------------------------------------------------------------
--- hGetLine
+Prelude - GHC.IO.lhs, and several other places including
+ GHC.Exception.lhs.
--- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
--- the duration.
+Libraries - parts of hslibs/lang.
--- | Computation 'hGetLine' @hdl@ reads a line from the file or
--- channel managed by @hdl@.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file is encountered when reading
--- the /first/ character of the line.
---
--- If 'hGetLine' encounters end-of-file at any other point while reading
--- in a line, it is treated as a line terminator and the (partial)
--- line is returned.
-
-hGetLine :: Handle -> IO String
-hGetLine h = do
- m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
- case haBufferMode handle_ of
- NoBuffering -> return Nothing
- LineBuffering -> do
- l <- hGetLineBuffered handle_
- return (Just l)
- BlockBuffering _ -> do
- l <- hGetLineBuffered handle_
- return (Just l)
- case m of
- Nothing -> hGetLineUnBuffered h
- Just l -> return l
-
-hGetLineBuffered :: Handle__ -> IO String
-hGetLineBuffered handle_ = do
- let ref = haBuffer handle_
- buf <- readIORef ref
- hGetLineBufferedLoop handle_ ref buf []
-
-hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
- -> IO String
-hGetLineBufferedLoop handle_ ref
- buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } xss =
- let
- -- find the end-of-line character, if there is one
- loop raw r
- | r == w = return (False, w)
- | otherwise = do
- (c,r') <- readCharFromBuffer raw r
- if c == '\n'
- then return (True, r) -- NB. not r': don't include the '\n'
- else loop raw r'
- in do
- (eol, off) <- loop raw0 r0
-
-#ifdef DEBUG_DUMP
- puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
-#endif
-
- xs <- unpack raw0 r0 off
-
- -- if eol == True, then off is the offset of the '\n'
- -- otherwise off == w and the buffer is now empty.
- if eol
- then do if (w == off + 1)
- then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- else writeIORef ref buf{ bufRPtr = off + 1 }
- return (concat (reverse (xs:xss)))
- else do
- maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
- buf{ bufWPtr=0, bufRPtr=0 }
- case maybe_buf of
- -- Nothing indicates we caught an EOF, and we may have a
- -- partial line to return.
- Nothing -> do
- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- let str = concat (reverse (xs:xss))
- if not (null str)
- then return str
- else ioe_EOF
- Just new_buf ->
- hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
-
-maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer)
-maybeFillReadBuffer fd is_line is_stream buf
- = catch
- (do buf' <- fillReadBuffer fd is_line is_stream buf
- return (Just buf')
- )
- (\e -> do if isEOFError e
- then return Nothing
- else ioError e)
-
-
-unpack :: RawBuffer -> Int -> Int -> IO [Char]
-unpack _ _ 0 = return ""
-unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s
- where
- unpackRB acc i s
- | i <# r = (# s, acc #)
- | otherwise =
- case readCharArray# buf i s of
- (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'
-
-
-hGetLineUnBuffered :: Handle -> IO String
-hGetLineUnBuffered h = do
- c <- hGetChar h
- if c == '\n' then
- return ""
- else do
- 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)
+--SDM
+-}
--- -----------------------------------------------------------------------------
--- hGetContents
+{-|
+A value of type @'IO' a@ is a computation which, when performed,
+does some I\/O before returning a value of type @a@.
--- hGetContents on a DuplexHandle only affects the read side: you can
--- carry on writing to it afterwards.
+There is really only one way to \"perform\" an I\/O action: bind it to
+@Main.main@ in your program. When your program is run, the I\/O will
+be performed. It isn't possible to perform I\/O from an arbitrary
+function, unless that function is itself in the 'IO' monad and called
+at some point, directly or indirectly, from @Main.main@.
--- | Computation 'hGetContents' @hdl@ returns the list of characters
--- corresponding to the unread portion of the channel or file managed
--- by @hdl@, which is put into an intermediate state, /semi-closed/.
--- In this state, @hdl@ is effectively closed,
--- but items are read from @hdl@ on demand and accumulated in a special
--- list returned by 'hGetContents' @hdl@.
---
--- Any operation that fails because a handle is closed,
--- also fails if a handle is semi-closed. The only exception is 'hClose'.
--- A semi-closed handle becomes closed:
---
--- * if 'hClose' is applied to it;
---
--- * if an I\/O error occurs when reading an item from the handle;
---
--- * or once the entire contents of the handle has been read.
---
--- Once a semi-closed handle becomes closed, the contents of the
--- associated list becomes fixed. The contents of this final list is
--- only partially specified: it will contain at least all the items of
--- the stream that were evaluated prior to the handle becoming closed.
---
--- Any I\/O errors encountered while a handle is semi-closed are simply
--- discarded.
---
--- This operation may fail with:
---
--- * 'isEOFError' if the end of file has been reached.
-
-hGetContents :: Handle -> IO String
-hGetContents handle =
- withHandle "hGetContents" handle $ \handle_ ->
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notReadable
- WriteHandle -> ioe_notReadable
- _ -> do xs <- lazyRead handle
- return (handle_{ haType=SemiClosedHandle}, xs )
-
--- Note that someone may close the semi-closed handle (or change its
--- buffering), so each time these lazy read functions are pulled on,
--- they have to check whether the handle has indeed been closed.
-
-lazyRead :: Handle -> IO String
-lazyRead handle =
- unsafeInterleaveIO $
- withHandle "lazyRead" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> return (handle_, "")
- SemiClosedHandle -> lazyRead' handle handle_
- _ -> ioException
- (IOError (Just handle) IllegalOperation "lazyRead"
- "illegal handle type" Nothing Nothing)
-
-lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char])
-lazyRead' h handle_ = do
- let ref = haBuffer handle_
- fd = haFD handle_
-
- -- even a NoBuffering handle can have a char in the buffer...
- -- (see hLookAhead)
- buf <- readIORef ref
- if not (bufferEmpty buf)
- then lazyReadHaveBuffer h handle_ fd ref buf
- else do
-
- case haBufferMode handle_ of
- NoBuffering -> do
- -- make use of the minimal buffer we already have
- let !raw = bufBuf buf
- r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
- if r == 0
- then do (handle_', _) <- hClose_help handle_
- return (handle_', "")
- else do (c,_) <- readCharFromBuffer raw 0
- rest <- lazyRead h
- return (handle_, c : rest)
-
- LineBuffering -> lazyReadBuffered h handle_ fd ref buf
- BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
-
--- we never want to block during the read, so we call fillReadBuffer with
--- is_line==True, which tells it to "just read what there is".
-lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer
- -> IO (Handle__, [Char])
-lazyReadBuffered h handle_ fd ref buf = do
- catch
- (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
- lazyReadHaveBuffer h handle_ fd ref buf'
- )
- -- all I/O errors are discarded. Additionally, we close the handle.
- (\_ -> do (handle_', _) <- hClose_help handle_
- return (handle_', "")
- )
-
-lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char])
-lazyReadHaveBuffer h handle_ _ ref buf = do
- more <- lazyRead h
- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
- return (handle_, s)
-
-
-unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
-unpackAcc _ _ 0 acc = return acc
-unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s
- where
- unpackRB acc i s
- | i <# r = (# s, acc #)
- | otherwise =
- case readCharArray# buf i s of
- (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'
+'IO' is a monad, so 'IO' actions can be combined using either the do-notation
+or the '>>' and '>>=' operations from the 'Monad' class.
+-}
+newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
+
+unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
+unIO (IO a) = a
+
+instance Functor IO where
+ fmap f x = x >>= (return . f)
+
+instance Monad IO where
+ {-# INLINE return #-}
+ {-# INLINE (>>) #-}
+ {-# INLINE (>>=) #-}
+ m >> k = m >>= \ _ -> k
+ return x = returnIO x
+
+ m >>= k = bindIO m k
+ fail s = failIO s
+
+liftIO :: IO a -> State# RealWorld -> STret RealWorld a
+liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
+
+bindIO :: IO a -> (a -> IO b) -> IO b
+bindIO (IO m) k = IO ( \ s ->
+ case m s of
+ (# new_s, a #) -> unIO (k a) new_s
+ )
+
+thenIO :: IO a -> IO b -> IO b
+thenIO (IO m) k = IO ( \ s ->
+ case m s of
+ (# new_s, _ #) -> unIO k new_s
+ )
+
+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))
+
+failIO :: String -> IO a
+failIO s = IO (raiseIO# (toException (userError s)))
-- ---------------------------------------------------------------------------
--- hPutChar
+-- Coercions between IO and ST
--- | Computation '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@.
---
--- This operation may fail with:
---
--- * 'isFullError' if the device is full; or
+-- | A monad transformer embedding strict state transformers in the 'IO'
+-- monad. The 'RealWorld' parameter indicates that the internal state
+-- used by the 'ST' computation is a special one supplied by the 'IO'
+-- monad, and thus distinct from those used by invocations of 'runST'.
+stToIO :: ST RealWorld a -> IO a
+stToIO (ST m) = IO m
+
+ioToST :: IO a -> ST RealWorld a
+ioToST (IO m) = (ST m)
+
+-- This relies on IO and ST having the same representation modulo the
+-- constraint on the type of the state
--
--- * 'isPermissionError' if another system resource limit would be exceeded.
-
-hPutChar :: Handle -> Char -> IO ()
-hPutChar handle c = do
- c `seq` return ()
- wantWritableHandle "hPutChar" handle $ \ handle_ -> do
- let fd = haFD handle_
- case haBufferMode handle_ of
- LineBuffering -> hPutcBuffered handle_ True c
- BlockBuffering _ -> hPutcBuffered handle_ False c
- NoBuffering ->
- with (castCharToCChar c) $ \buf -> do
- writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
- return ()
-
-hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
-hPutcBuffered handle_ is_line c = do
- let ref = haBuffer handle_
- buf <- readIORef ref
- let w = bufWPtr buf
- w' <- writeCharIntoBuffer (bufBuf buf) w c
- let new_buf = buf{ bufWPtr = w' }
- if bufferFull new_buf || is_line && c == '\n'
- then do
- flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
- writeIORef ref flushed_buf
- else do
- writeIORef ref new_buf
-
-
-hPutChars :: Handle -> [Char] -> IO ()
-hPutChars _ [] = return ()
-hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
+unsafeIOToST :: IO a -> ST s a
+unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s
+
+unsafeSTToIO :: ST s a -> IO a
+unsafeSTToIO (ST m) = IO (unsafeCoerce# m)
-- ---------------------------------------------------------------------------
--- hPutStr
+-- Unsafe IO operations
+
+{-|
+This is the \"back door\" into the 'IO' monad, allowing
+'IO' computation to be performed at any time. For
+this to be safe, the 'IO' computation should be
+free of side effects and independent of its environment.
+
+If the I\/O computation wrapped in 'unsafePerformIO'
+performs side effects, then the relative order in which those side
+effects take place (relative to the main I\/O trunk, or other calls to
+'unsafePerformIO') is indeterminate. You have to be careful when
+writing and compiling modules that use 'unsafePerformIO':
+
+ * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@
+ that calls 'unsafePerformIO'. If the call is inlined,
+ the I\/O may be performed more than once.
+
+ * Use the compiler flag @-fno-cse@ to prevent common sub-expression
+ elimination being performed on the module, which might combine
+ two side effects that were meant to be separate. A good example
+ is using multiple global variables (like @test@ in the example below).
+
+ * Make sure that the either you switch off let-floating, or that the
+ call to 'unsafePerformIO' cannot float outside a lambda. For example,
+ if you say:
+ @
+ f x = unsafePerformIO (newIORef [])
+ @
+ you may get only one reference cell shared between all calls to @f@.
+ Better would be
+ @
+ f x = unsafePerformIO (newIORef [x])
+ @
+ because now it can't float outside the lambda.
+
+It is less well known that
+'unsafePerformIO' is not type safe. For example:
+
+> test :: IORef [a]
+> test = unsafePerformIO $ newIORef []
+>
+> main = do
+> writeIORef test [42]
+> bang <- readIORef test
+> print (bang :: [Char])
+
+This program will core dump. This problem with polymorphic references
+is well known in the ML community, and does not arise with normal
+monadic use of references. There is no easy way to make it impossible
+once you use 'unsafePerformIO'. Indeed, it is
+possible to write @coerce :: a -> b@ with the
+help of 'unsafePerformIO'. So be careful!
+-}
+unsafePerformIO :: IO a -> a
+unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
+
+{-|
+This version of 'unsafePerformIO' is slightly more efficient,
+because it omits the check that the IO is only being performed by a
+single thread. Hence, when you write 'unsafeDupablePerformIO',
+there is a possibility that the IO action may be performed multiple
+times (on a multiprocessor), and you should therefore ensure that
+it gives the same results each time.
+-}
+{-# NOINLINE unsafeDupablePerformIO #-}
+unsafeDupablePerformIO :: IO a -> a
+unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
+
+-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with
+-- GHC.ST.runST. Essentially the issue is that the IO computation
+-- inside unsafePerformIO must be atomic: it must either all run, or
+-- not at all. If we let the compiler see the application of the IO
+-- to realWorld#, it might float out part of the IO.
+
+-- Why is there a call to 'lazy' in unsafeDupablePerformIO?
+-- If we don't have it, the demand analyser discovers the following strictness
+-- for unsafeDupablePerformIO: C(U(AV))
+-- But then consider
+-- unsafeDupablePerformIO (\s -> let r = f x in
+-- case writeIORef v r s of (# s1, _ #) ->
+-- (# s1, r #)
+-- The strictness analyser will find that the binding for r is strict,
+-- (becuase of uPIO's strictness sig), and so it'll evaluate it before
+-- doing the writeIORef. This actually makes tests/lib/should_run/memo002
+-- get a deadlock!
+--
+-- Solution: don't expose the strictness of unsafeDupablePerformIO,
+-- by hiding it with 'lazy'
+
+{-|
+'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
+When passed a value of type @IO a@, the 'IO' will only be performed
+when the value of the @a@ is demanded. This is used to implement lazy
+file reading, see 'System.IO.hGetContents'.
+-}
+{-# INLINE unsafeInterleaveIO #-}
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)
+
+-- We believe that INLINE on unsafeInterleaveIO is safe, because the
+-- state from this IO thread is passed explicitly to the interleaved
+-- IO, so it cannot be floated out and shared.
+
+{-# INLINE unsafeDupableInterleaveIO #-}
+unsafeDupableInterleaveIO :: IO a -> IO a
+unsafeDupableInterleaveIO (IO m)
+ = IO ( \ s -> let
+ r = case m s of (# _, res #) -> res
+ in
+ (# s, r #))
+
+{-|
+Ensures that the suspensions under evaluation by the current thread
+are unique; that is, the current thread is not evaluating anything
+that is also under evaluation by another thread that has also executed
+'noDuplicate'.
+
+This operation is used in the definition of 'unsafePerformIO' to
+prevent the IO action from being executed multiple times, which is usually
+undesirable.
+-}
+noDuplicate :: IO ()
+noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)
--- We go to some trouble to avoid keeping the handle locked while we're
--- evaluating the string argument to hPutStr, in case doing so triggers another
--- I/O operation on the same handle which would lead to deadlock. The classic
--- case is
---
--- putStr (trace "hello" "world")
---
--- so the basic scheme is this:
---
--- * copy the string into a fresh buffer,
--- * "commit" the buffer to the handle.
---
--- Committing may involve simply copying the contents of the new
--- buffer into the handle's buffer, flushing one or both buffers, or
--- maybe just swapping the buffers over (if the handle's buffer was
--- empty). See commitBuffer below.
+-- -----------------------------------------------------------------------------
+-- | File and directory names are values of type 'String', whose precise
+-- meaning is operating system dependent. Files can be opened, yielding a
+-- handle which can then be used to operate on the contents of that file.
--- | Computation 'hPutStr' @hdl s@ writes the string
--- @s@ to the file or channel managed by @hdl@.
---
--- This operation may fail with:
---
--- * 'isFullError' if the device is full; or
---
--- * 'isPermissionError' if another system resource limit would be exceeded.
-
-hPutStr :: Handle -> String -> IO ()
-hPutStr handle str = do
- buffer_mode <- wantWritableHandle "hPutStr" handle
- (\ handle_ -> do getSpareBuffer handle_)
- case buffer_mode of
- (NoBuffering, _) -> do
- hPutChars handle str -- v. slow, but we don't care
- (LineBuffering, buf) -> do
- writeLines handle buf str
- (BlockBuffering _, buf) -> do
- writeBlocks handle buf str
-
-
-getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
-getSpareBuffer Handle__{haBuffer=ref,
- haBuffers=spare_ref,
- haBufferMode=mode}
- = do
- case mode of
- NoBuffering -> return (mode, error "no buffer!")
- _ -> do
- bufs <- readIORef spare_ref
- buf <- readIORef ref
- case bufs of
- BufferListCons b rest -> do
- writeIORef spare_ref rest
- return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
- BufferListNil -> do
- new_buf <- allocateBuffer (bufSize buf) WriteBuffer
- return (mode, new_buf)
-
-
-writeLines :: Handle -> Buffer -> String -> IO ()
-writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
- let
- shoveString :: Int -> [Char] -> IO ()
- -- check n == len first, to ensure that shoveString is strict in n.
- shoveString n cs | n == len = do
- new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeLines hdl new_buf cs
- shoveString n [] = do
- commitBuffer hdl raw len n False{-no flush-} True{-release-}
- return ()
- shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
- if (c == '\n')
- then do
- new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
- writeLines hdl new_buf cs
- else
- shoveString n' cs
- in
- shoveString 0 s
-
-writeBlocks :: Handle -> Buffer -> String -> IO ()
-writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
- let
- shoveString :: Int -> [Char] -> IO ()
- -- check n == len first, to ensure that shoveString is strict in n.
- shoveString n cs | n == len = do
- new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeBlocks hdl new_buf cs
- shoveString n [] = do
- commitBuffer hdl raw len n False{-no flush-} True{-release-}
- return ()
- shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
- shoveString n' cs
- in
- shoveString 0 s
+type FilePath = String
-- -----------------------------------------------------------------------------
--- commitBuffer handle buf sz count flush release
---
--- Write the contents of the buffer 'buf' ('sz' bytes long, containing
--- 'count' bytes of data) to handle (handle must be block or line buffered).
---
--- Implementation:
---
--- for block/line buffering,
--- 1. If there isn't room in the handle buffer, flush the handle
--- buffer.
---
--- 2. If the handle buffer is empty,
--- if flush,
--- then write buf directly to the device.
--- else swap the handle buffer with buf.
---
--- 3. If the handle buffer is non-empty, copy buf into the
--- handle buffer. Then, if flush != 0, flush
--- the buffer.
-
-commitBuffer
- :: Handle -- handle to commit to
- -> RawBuffer -> Int -- address and size (in bytes) of buffer
- -> Int -- number of bytes of data in buffer
- -> Bool -- True <=> flush the handle afterward
- -> Bool -- release the buffer?
- -> IO Buffer
-
-commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
- wantWritableHandle "commitAndReleaseBuffer" hdl $
- commitBuffer' raw sz count flush release
-
--- Explicitly lambda-lift this function to subvert GHC's full laziness
--- optimisations, which otherwise tends to float out subexpressions
--- past the \handle, which is really a pessimisation in this case because
--- that lambda is a one-shot lambda.
---
--- Don't forget to export the function, to stop it being inlined too
--- (this appears to be better than NOINLINE, because the strictness
--- analyser still gets to worker-wrapper it).
---
--- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
---
-commitBuffer' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__
- -> IO Buffer
-commitBuffer' raw sz@(I# _) count@(I# _) flush release
- handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
-
-#ifdef DEBUG_DUMP
- puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
- ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
-#endif
-
- old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }
- <- readIORef ref
-
- buf_ret <-
- -- enough room in handle buffer?
- if (not flush && (size - w > count))
- -- The > is to be sure that we never exactly fill
- -- up the buffer, which would require a flush. So
- -- if copying the new data into the buffer would
- -- make the buffer full, we just flush the existing
- -- buffer and the new data immediately, rather than
- -- copying before flushing.
-
- -- not flushing, and there's enough room in the buffer:
- -- just copy the data in and update bufWPtr.
- then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
- writeIORef ref old_buf{ bufWPtr = w + count }
- return (newEmptyBuffer raw WriteBuffer sz)
-
- -- else, we have to flush
- else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
-
- let this_buf =
- Buffer{ bufBuf=raw, bufState=WriteBuffer,
- bufRPtr=0, bufWPtr=count, bufSize=sz }
-
- -- if: (a) we don't have to flush, and
- -- (b) size(new buffer) == size(old buffer), and
- -- (c) new buffer is not full,
- -- we can just just swap them over...
- if (not flush && sz == size && count /= sz)
- then do
- writeIORef ref this_buf
- return flushed_buf
-
- -- otherwise, we have to flush the new data too,
- -- and start with a fresh buffer
- else do
- flushWriteBuffer fd (haIsStream handle_) this_buf
- writeIORef ref flushed_buf
- -- if the sizes were different, then allocate
- -- a new buffer of the correct size.
- if sz == size
- then return (newEmptyBuffer raw WriteBuffer sz)
- else allocateBuffer size WriteBuffer
-
- -- release the buffer if necessary
- case buf_ret of
- Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
- if release && buf_ret_sz == size
- then do
- spare_bufs <- readIORef spare_buf_ref
- writeIORef spare_buf_ref
- (BufferListCons buf_ret_raw spare_bufs)
- return buf_ret
- else
- return buf_ret
+-- Primitive catch and throwIO
--- ---------------------------------------------------------------------------
--- Reading/writing sequences of bytes.
+{-
+catchException used to handle the passing around of the state to the
+action and the handler. This turned out to be a bad idea - it meant
+that we had to wrap both arguments in thunks so they could be entered
+as normal (remember IO returns an unboxed pair...).
--- ---------------------------------------------------------------------------
--- hPutBuf
+Now catch# has type
--- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
--- buffer @buf@ to the handle @hdl@. It returns ().
---
--- This operation may fail with:
---
--- * 'ResourceVanished' if the handle is a pipe or socket, and the
--- reading end is closed. (If this is a POSIX system, and the program
--- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
--- instead, whose default action is to terminate the program).
-
-hPutBuf :: Handle -- handle to write to
- -> Ptr a -- address of buffer
- -> Int -- number of bytes of data in buffer
- -> IO ()
-hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
-
-hPutBufNonBlocking
- :: Handle -- handle to write to
- -> Ptr a -- address of buffer
- -> Int -- number of bytes of data in buffer
- -> IO Int -- returns: number of bytes written
-hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
-
-hPutBuf':: Handle -- handle to write to
- -> Ptr a -- address of buffer
- -> Int -- number of bytes of data in buffer
- -> Bool -- allow blocking?
- -> IO Int
-hPutBuf' handle ptr count can_block
- | count == 0 = return 0
- | count < 0 = illegalBufferSize handle "hPutBuf" count
- | otherwise =
- wantWritableHandle "hPutBuf" handle $
- \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
- bufWrite fd ref is_stream ptr count can_block
-
-bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int
-bufWrite fd ref is_stream ptr count can_block =
- seq count $ seq fd $ do -- strictness hack
- old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }
- <- readIORef ref
-
- -- enough room in handle buffer?
- if (size - w > count)
- -- There's enough room in the buffer:
- -- just copy the data in and update bufWPtr.
- then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)
- writeIORef ref old_buf{ bufWPtr = w + count }
- return count
-
- -- else, we have to flush
- else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
- -- TODO: we should do a non-blocking flush here
- writeIORef ref flushed_buf
- -- if we can fit in the buffer, then just loop
- if count < size
- then bufWrite fd ref is_stream ptr count can_block
- else if can_block
- then do writeChunk fd is_stream (castPtr ptr) count
- return count
- else writeChunkNonBlocking fd is_stream ptr count
-
-writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
-writeChunk fd is_stream ptr bytes0 = loop 0 bytes0
- where
- loop :: Int -> Int -> IO ()
- loop _ bytes | bytes <= 0 = return ()
- loop off bytes = do
- r <- fromIntegral `liftM`
- writeRawBufferPtr "writeChunk" fd is_stream ptr
- off (fromIntegral bytes)
- -- write can't return 0
- loop (off + r) (bytes - r)
-
-writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
-writeChunkNonBlocking fd
-#ifndef mingw32_HOST_OS
- _
-#else
- is_stream
-#endif
- ptr bytes0 = loop 0 bytes0
- where
- loop :: Int -> Int -> IO Int
- loop off bytes | bytes <= 0 = return off
- loop off bytes = do
-#ifndef mingw32_HOST_OS
- ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)
- let r = fromIntegral ssize :: Int
- if (r == -1)
- then do errno <- getErrno
- if (errno == eAGAIN || errno == eWOULDBLOCK)
- then return off
- else throwErrno "writeChunk"
- else loop (off + r) (bytes - r)
-#else
- (ssize, rc) <- asyncWrite (fromIntegral fd)
- (fromIntegral $ fromEnum is_stream)
- (fromIntegral bytes)
- (ptr `plusPtr` off)
- let r = fromIntegral ssize :: Int
- if r == (-1)
- then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
- else loop (off + r) (bytes - r)
-#endif
+ catch# :: IO a -> (b -> IO a) -> IO a
--- ---------------------------------------------------------------------------
--- hGetBuf
+(well almost; the compiler doesn't know about the IO newtype so we
+have to work around that in the definition of catchException below).
+-}
--- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
--- into the buffer @buf@ until either EOF is reached or
--- @count@ 8-bit bytes have been read.
--- It returns the number of bytes actually read. This may be zero if
--- EOF was reached before any data was read (or if @count@ is zero).
---
--- 'hGetBuf' never raises an EOF exception, instead it returns a value
--- smaller than @count@.
---
--- If the handle is a pipe or socket, and the writing end
--- is closed, 'hGetBuf' will behave as if EOF was reached.
-
-hGetBuf :: Handle -> Ptr a -> Int -> IO Int
-hGetBuf h ptr count
- | count == 0 = return 0
- | count < 0 = illegalBufferSize h "hGetBuf" count
- | otherwise =
- wantReadableHandle "hGetBuf" h $
- \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
- bufRead fd ref is_stream ptr 0 count
-
--- small reads go through the buffer, large reads are satisfied by
--- taking data first from the buffer and then direct from the file
--- descriptor.
-bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int
-bufRead fd ref is_stream ptr so_far count =
- seq fd $ seq so_far $ seq count $ do -- strictness hack
- buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
- if bufferEmpty buf
- then if count > sz -- small read?
- then do rest <- readChunk fd is_stream ptr count
- return (so_far + rest)
- else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
- case mb_buf of
- Nothing -> return so_far -- got nothing, we're done
- Just buf' -> do
- writeIORef ref buf'
- bufRead fd ref is_stream ptr so_far count
- else do
- let avail = w - r
- if (count == avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- return (so_far + count)
- else do
- if (count < avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufRPtr = r + count }
- return (so_far + count)
- else do
-
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- let remaining = count - avail
- so_far' = so_far + avail
- ptr' = ptr `plusPtr` avail
-
- if remaining < sz
- then bufRead fd ref is_stream ptr' so_far' remaining
- else do
-
- rest <- readChunk fd is_stream ptr' remaining
- return (so_far' + rest)
-
-readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
-readChunk fd is_stream ptr bytes0 = loop 0 bytes0
- where
- loop :: Int -> Int -> IO Int
- loop off bytes | bytes <= 0 = return off
- loop off bytes = do
- r <- fromIntegral `liftM`
- readRawBufferPtr "readChunk" fd is_stream
- (castPtr ptr) off (fromIntegral bytes)
- if r == 0
- then return off
- else loop (off + r) (bytes - r)
-
-
--- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
--- into the buffer @buf@ until either EOF is reached, or
--- @count@ 8-bit bytes have been read, or there is no more data available
--- to read immediately.
+catchException :: Exception e => IO a -> (e -> IO a) -> IO a
+catchException (IO io) handler = IO $ catch# io handler'
+ where handler' e = case fromException e of
+ Just e' -> unIO (handler e')
+ Nothing -> raise# e
+
+catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
+catchAny (IO io) handler = IO $ catch# io handler'
+ where handler' (SomeException e) = unIO (handler e)
+
+-- | A variant of 'throw' that can only be used within the 'IO' monad.
--
--- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
--- never block waiting for data to become available, instead it returns
--- only whatever data is available. To wait for data to arrive before
--- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
+-- Although 'throwIO' has a type that is an instance of the type of 'throw', the
+-- two functions are subtly different:
--
--- If the handle is a pipe or socket, and the writing end
--- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
+-- > throw e `seq` x ===> throw e
+-- > throwIO e `seq` x ===> x
--
-hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
-hGetBufNonBlocking h ptr count
- | count == 0 = return 0
- | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
- | otherwise =
- wantReadableHandle "hGetBufNonBlocking" h $
- \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
- bufReadNonBlocking fd ref is_stream ptr 0 count
-
-bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int
- -> IO Int
-bufReadNonBlocking fd ref is_stream ptr so_far count =
- seq fd $ seq so_far $ seq count $ do -- strictness hack
- buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
- if bufferEmpty buf
- then if count > sz -- large read?
- then do rest <- readChunkNonBlocking fd is_stream ptr count
- return (so_far + rest)
- else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
- case buf' of { Buffer{ bufWPtr=w' } ->
- if (w' == 0)
- then return so_far
- else do writeIORef ref buf'
- bufReadNonBlocking fd ref is_stream ptr
- so_far (min count w')
- -- NOTE: new count is min count w'
- -- so we will just copy the contents of the
- -- buffer in the recursive call, and not
- -- loop again.
- }
- else do
- let avail = w - r
- if (count == avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- return (so_far + count)
- else do
- if (count < avail)
- then do
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
- writeIORef ref buf{ bufRPtr = r + count }
- return (so_far + count)
- else do
-
- memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
- writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
- let remaining = count - avail
- so_far' = so_far + avail
- ptr' = ptr `plusPtr` avail
-
- -- we haven't attempted to read anything yet if we get to here.
- if remaining < sz
- then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
- else do
-
- rest <- readChunkNonBlocking fd is_stream ptr' remaining
- return (so_far' + rest)
-
-
-readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
-readChunkNonBlocking fd is_stream ptr bytes = do
- fromIntegral `liftM`
- readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream
- (castPtr ptr) 0 (fromIntegral bytes)
-
- -- we don't have non-blocking read support on Windows, so just invoke
- -- the ordinary low-level read which will block until data is available,
- -- but won't wait for the whole buffer to fill.
-
-slurpFile :: FilePath -> IO (Ptr (), Int)
-slurpFile fname = do
- handle <- openFile fname ReadMode
- sz <- hFileSize handle
- if sz > fromIntegral (maxBound::Int) then
- ioError (userError "slurpFile: file too big")
- else do
- let sz_i = fromIntegral sz
- if sz_i == 0 then return (nullPtr, 0) else do
- chunk <- mallocBytes sz_i
- r <- hGetBuf handle chunk sz_i
- hClose handle
- return (chunk, r)
-
--- ---------------------------------------------------------------------------
--- memcpy wrappers
-
-foreign import ccall unsafe "__hscore_memcpy_src_off"
- memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
-foreign import ccall unsafe "__hscore_memcpy_src_off"
- memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
-foreign import ccall unsafe "__hscore_memcpy_dst_off"
- memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
-foreign import ccall unsafe "__hscore_memcpy_dst_off"
- memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ())
+-- The first example will cause the exception @e@ to be raised,
+-- whereas the second one won\'t. In fact, 'throwIO' will only cause
+-- an exception to be raised when it is used within the 'IO' monad.
+-- The 'throwIO' variant should be used in preference to 'throw' to
+-- raise an exception within the 'IO' monad because it guarantees
+-- ordering with respect to other 'IO' operations, whereas 'throw'
+-- does not.
+throwIO :: Exception e => e -> IO a
+throwIO e = IO (raiseIO# (toException e))
------------------------------------------------------------------------------
--- Internal Utils
-
-illegalBufferSize :: Handle -> String -> Int -> IO a
-illegalBufferSize handle fn sz =
- ioException (IOError (Just handle)
- InvalidArgument fn
- ("illegal buffer size " ++ showsPrec 9 sz [])
- Nothing Nothing)
+-- -----------------------------------------------------------------------------
+-- Controlling asynchronous exception delivery
+
+-- | Applying 'block' to a computation will
+-- execute that computation with asynchronous exceptions
+-- /blocked/. That is, any thread which
+-- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be
+-- blocked until asynchronous exceptions are enabled again. There\'s
+-- no need to worry about re-enabling asynchronous exceptions; that is
+-- done automatically on exiting the scope of
+-- 'block'.
+--
+-- Threads created by 'Control.Concurrent.forkIO' inherit the blocked
+-- state from the parent; that is, to start a thread in blocked mode,
+-- use @block $ forkIO ...@. This is particularly useful if you need to
+-- establish an exception handler in the forked thread before any
+-- asynchronous exceptions are received.
+block :: IO a -> IO a
+
+-- | To re-enable asynchronous exceptions inside the scope of
+-- 'block', 'unblock' can be
+-- used. It scopes in exactly the same way, so on exit from
+-- 'unblock' asynchronous exception delivery will
+-- be disabled again.
+unblock :: IO a -> IO a
+
+block (IO io) = IO $ blockAsyncExceptions# io
+unblock (IO io) = IO $ unblockAsyncExceptions# io
+
+-- | returns True if asynchronous exceptions are blocked in the
+-- current thread.
+blocked :: IO Bool
+blocked = IO $ \s -> case asyncExceptionsBlocked# s of
+ (# s', i #) -> (# s', i /=# 0# #)
+
+onException :: IO a -> IO b -> IO a
+onException io what = io `catchException` \e -> do what
+ throw (e :: SomeException)
+
+finally :: IO a -- ^ computation to run first
+ -> IO b -- ^ computation to run afterward (even if an exception
+ -- was raised)
+ -> IO a -- returns the value from the first computation
+a `finally` sequel =
+ block (do
+ r <- unblock a `onException` sequel
+ sequel
+ return r
+ )
+
+-- | Forces its argument to be evaluated to weak head normal form when
+-- the resultant 'IO' action is executed. It can be used to order
+-- evaluation with respect to other 'IO' operations; its semantics are
+-- given by
+--
+-- > evaluate x `seq` y ==> y
+-- > evaluate x `catch` f ==> (return $! x) `catch` f
+-- > evaluate x >>= f ==> (return $! x) >>= f
+--
+-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the
+-- same as @(return $! x)@. A correct definition is
+--
+-- > evaluate x = (return $! x) >>= return
+--
+evaluate :: a -> IO a
+evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
+ -- NB. can't write
+ -- a `seq` (# s, a #)
+ -- because we can't have an unboxed tuple as a function argument
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Buffer
+-- Copyright : (c) The University of Glasgow 2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- Buffers used in the IO system
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Buffer (
+ -- * Buffers of any element
+ Buffer(..), BufferState(..), CharBuffer, CharBufElem,
+
+ -- ** Creation
+ newByteBuffer,
+ newCharBuffer,
+ newBuffer,
+ emptyBuffer,
+
+ -- ** Insertion/removal
+ bufferRemove,
+ bufferAdd,
+ slideContents,
+ bufferAdjustL,
+
+ -- ** Inspecting
+ isEmptyBuffer,
+ isFullBuffer,
+ isFullCharBuffer,
+ isWriteBuffer,
+ bufferElems,
+ bufferAvailable,
+ summaryBuffer,
+
+ -- ** Operating on the raw buffer as a Ptr
+ withBuffer,
+ withRawBuffer,
+
+ -- ** Assertions
+ checkBuffer,
+
+ -- * Raw buffers
+ RawBuffer,
+ readWord8Buf,
+ writeWord8Buf,
+ RawCharBuffer,
+ peekCharBuf,
+ readCharBuf,
+ writeCharBuf,
+ readCharBufPtr,
+ writeCharBufPtr,
+ charSize,
+ ) where
+
+import GHC.Base
+import GHC.IO
+import GHC.Num
+import GHC.Ptr
+import GHC.Word
+import GHC.Show
+import GHC.Real
+import Foreign.C.Types
+import Foreign.ForeignPtr
+import Foreign.Storable
+
+-- Char buffers use either UTF-16 or UTF-32, with the endianness matching
+-- the endianness of the host.
+--
+-- Invariants:
+-- * a Char buffer consists of *valid* UTF-16 or UTF-32
+-- * only whole characters: no partial surrogate pairs
+
+-- #define CHARBUF_UTF16
+#define CHARBUF_UTF32
+
+-- ---------------------------------------------------------------------------
+-- Raw blocks of data
+
+type RawBuffer e = ForeignPtr e
+
+readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
+readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix
+
+writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
+writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w
+
+#ifdef CHARBUF_UTF16
+type CharBufElem = Word16
+#else
+type CharBufElem = Char
+#endif
+
+type RawCharBuffer = RawBuffer CharBufElem
+
+peekCharBuf :: RawCharBuffer -> Int -> IO Char
+peekCharBuf arr ix = withForeignPtr arr $ \p -> do
+ (c,_) <- readCharBufPtr p ix
+ return c
+
+{-# INLINE readCharBuf #-}
+readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
+readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix
+
+{-# INLINE writeCharBuf #-}
+writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
+writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c
+
+{-# INLINE readCharBufPtr #-}
+readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
+#ifdef CHARBUF_UTF16
+readCharBufPtr p ix = do
+ c1 <- peekElemOff p ix
+ if (c1 < 0xd800 || c1 > 0xdbff)
+ then return (chr (fromIntegral c1), ix+1)
+ else do c2 <- peekElemOff p (ix+1)
+ return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +
+ (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)
+#else
+readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)
+#endif
+
+{-# INLINE writeCharBufPtr #-}
+writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
+#ifdef CHARBUF_UTF16
+writeCharBufPtr p ix ch
+ | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)
+ return (ix+1)
+ | otherwise = do let c' = c - 0x10000
+ pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))
+ pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))
+ return (ix+2)
+ where
+ c = ord ch
+#else
+writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)
+#endif
+
+charSize :: Int
+#ifdef CHARBUF_UTF16
+charSize = 2
+#else
+charSize = 4
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Buffers
+
+-- The buffer is represented by a mutable variable containing a
+-- record, where the record contains the raw buffer and the start/end
+-- points of the filled portion. We use a mutable variable so that
+-- the common operation of writing (or reading) some data from (to)
+-- the buffer doesn't need to modify, and hence copy, the handle
+-- itself, it just updates the buffer.
+
+-- There will be some allocation involved in a simple hPutChar in
+-- order to create the new Buffer structure (below), but this is
+-- relatively small, and this only has to be done once per write
+-- operation.
+
+-- | A mutable array of bytes that can be passed to foreign functions.
+data Buffer e
+ = Buffer {
+ bufRaw :: !(RawBuffer e),
+ bufState :: BufferState,
+ bufSize :: !Int, -- in elements, not bytes
+ bufL :: !Int, -- offset of first item in the buffer
+ bufR :: !Int -- offset of last item + 1
+ }
+
+#ifdef CHARBUF_UTF16
+type CharBuffer = Buffer Word16
+#else
+type CharBuffer = Buffer Char
+#endif
+
+data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
+
+withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
+withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f
+
+withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
+withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f
+
+isEmptyBuffer :: Buffer e -> Bool
+isEmptyBuffer Buffer{ bufR=w } = w == 0
+
+isFullBuffer :: Buffer e -> Bool
+isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w
+
+-- if a Char buffer does not have room for a surrogate pair, it is "full"
+isFullCharBuffer :: Buffer e -> Bool
+#ifdef CHARBUF_UTF16
+isFullCharBuffer buf = bufferAvailable buf < 2
+#else
+isFullCharBuffer = isFullBuffer
+#endif
+
+isWriteBuffer :: Buffer e -> Bool
+isWriteBuffer buf = case bufState buf of
+ WriteBuffer -> True
+ ReadBuffer -> False
+
+bufferElems :: Buffer e -> Int
+bufferElems Buffer{ bufR=w, bufL=r } = w - r
+
+bufferAvailable :: Buffer e -> Int
+bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w
+
+bufferRemove :: Int -> Buffer e -> Buffer e
+bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf
+
+bufferAdjustL :: Int -> Buffer e -> Buffer e
+bufferAdjustL l buf@Buffer{ bufR=w }
+ | l == w = buf{ bufL=0, bufR=0 }
+ | otherwise = buf{ bufL=l, bufR=w }
+
+bufferAdd :: Int -> Buffer e -> Buffer e
+bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }
+
+emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
+emptyBuffer raw sz state =
+ Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz }
+
+newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
+newByteBuffer c st = newBuffer c c st
+
+newCharBuffer :: Int -> BufferState -> IO CharBuffer
+newCharBuffer c st = newBuffer (c * charSize) c st
+
+newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
+newBuffer bytes sz state = do
+ fp <- mallocForeignPtrBytes bytes
+ return (emptyBuffer fp sz state)
+
+-- | slides the contents of the buffer to the beginning
+slideContents :: Buffer Word8 -> IO (Buffer Word8)
+slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do
+ let elems = r - l
+ withRawBuffer raw $ \p -> memcpy p (p `plusPtr` l) (fromIntegral elems)
+ return buf{ bufL=0, bufR=elems }
+
+foreign import ccall unsafe "memcpy"
+ memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
+
+summaryBuffer :: Buffer a -> String
+summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
+
+-- INVARIANTS on Buffers:
+-- * r <= w
+-- * if r == w, then r == 0 && w == 0
+-- * if state == WriteBuffer, then r == 0
+-- * a write buffer is never full. If an operation
+-- fills up the buffer, it will always flush it before
+-- returning.
+-- * a read buffer may be full as a result of hLookAhead. In normal
+-- operation, a read buffer always has at least one character of space.
+
+checkBuffer :: Buffer a -> IO ()
+checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
+ check buf (
+ size > 0
+ && r <= w
+ && w <= size
+ && ( r /= w || (r == 0 && w == 0) )
+ && ( state /= WriteBuffer || r == 0 )
+ && ( state /= WriteBuffer || w < size ) -- write buffer is never full
+ )
+
+check :: Buffer a -> Bool -> IO ()
+check _ True = return ()
+check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.BufferedIO
+-- Copyright : (c) The University of Glasgow 2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- Class of buffered IO devices
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.BufferedIO (
+ BufferedIO(..),
+ readBuf, readBufNonBlocking, writeBuf, writeBufNonBlocking
+ ) where
+
+import GHC.Base
+import GHC.Ptr
+import Data.Word
+import GHC.Num
+import GHC.Real
+import Data.Maybe
+import GHC.IO
+import GHC.IO.Device as IODevice
+import GHC.IO.Device as RawIO
+import GHC.IO.Buffer
+
+-- | The purpose of 'BufferedIO' is to provide a common interface for I/O
+-- devices that can read and write data through a buffer. Devices that
+-- implement 'BufferedIO' include ordinary files, memory-mapped files,
+-- and bytestrings. The underlying device implementing a 'Handle' must
+-- provide 'BufferedIO'.
+--
+class BufferedIO dev where
+ -- | allocate a new buffer. The size of the buffer is at the
+ -- discretion of the device; e.g. for a memory-mapped file the
+ -- buffer will probably cover the entire file.
+ newBuffer :: dev -> BufferState -> IO (Buffer Word8)
+
+ -- | reads bytes into the buffer, blocking if there are no bytes
+ -- available. Returns the number of bytes read (zero indicates
+ -- end-of-file), and the new buffer.
+ fillReadBuffer :: dev -> Buffer Word8 -> IO (Int, Buffer Word8)
+
+ -- | reads bytes into the buffer without blocking. Returns the
+ -- number of bytes read (Nothing indicates end-of-file), and the new
+ -- buffer.
+ fillReadBuffer0 :: dev -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)
+
+ -- | Flush all the data from the supplied write buffer out to the device
+ flushWriteBuffer :: dev -> Buffer Word8 -> IO ()
+
+ -- | Flush data from the supplied write buffer out to the device
+ -- without blocking. Returns the number of bytes written and the
+ -- remaining buffer.
+ flushWriteBuffer0 :: dev -> Buffer Word8 -> IO (Int, Buffer Word8)
+
+-- for an I/O device, these operations will perform reading/writing
+-- to/from the device.
+
+-- for a memory-mapped file, the buffer will be the whole file in
+-- memory. fillReadBuffer sets the pointers to encompass the whole
+-- file, and flushWriteBuffer will do nothing. A memory-mapped file
+-- has to maintain its own file pointer.
+
+-- for a bytestring, again the buffer should match the bytestring in
+-- memory.
+
+-- ---------------------------------------------------------------------------
+-- Low-level read/write to/from buffers
+
+-- These operations make it easy to implement an instance of 'BufferedIO'
+-- for an object that supports 'RawIO'.
+
+readBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8)
+readBuf dev bbuf = do
+ let bytes = bufferAvailable bbuf
+ res <- withBuffer bbuf $ \ptr ->
+ RawIO.read dev (ptr `plusPtr` bufR bbuf) (fromIntegral bytes)
+ let res' = fromIntegral res
+ return (res', bbuf{ bufR = bufR bbuf + res' })
+ -- zero indicates end of file
+
+readBufNonBlocking :: RawIO dev => dev -> Buffer Word8
+ -> IO (Maybe Int, -- Nothing ==> end of file
+ -- Just n ==> n bytes were read (n>=0)
+ Buffer Word8)
+readBufNonBlocking dev bbuf = do
+ let bytes = bufferAvailable bbuf
+ res <- withBuffer bbuf $ \ptr ->
+ IODevice.readNonBlocking dev (ptr `plusPtr` bufR bbuf) (fromIntegral bytes)
+ case res of
+ Nothing -> return (Nothing, bbuf)
+ Just n -> return (Just n, bbuf{ bufR = bufR bbuf + fromIntegral n })
+
+writeBuf :: RawIO dev => dev -> Buffer Word8 -> IO ()
+writeBuf dev bbuf = do
+ let bytes = bufferElems bbuf
+ withBuffer bbuf $ \ptr ->
+ IODevice.write dev (ptr `plusPtr` bufL bbuf) (fromIntegral bytes)
+
+-- XXX ToDo
+writeBufNonBlocking :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8)
+writeBufNonBlocking dev bbuf = do
+ let bytes = bufferElems bbuf
+ res <- withBuffer bbuf $ \ptr ->
+ IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf)
+ (fromIntegral bytes)
+ return (res, bbuf{ bufL = bufL bbuf + res })
+
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Device
+-- Copyright : (c) The University of Glasgow, 1994-2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- Type classes for I/O providers.
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Device (
+ RawIO(..),
+ IODevice(..),
+ IODeviceType(..),
+ SeekMode(..)
+ ) where
+
+import GHC.Base
+import GHC.Word
+import GHC.Arr
+import GHC.Enum
+import GHC.Read
+import GHC.Show
+import GHC.Ptr
+import Data.Maybe
+import GHC.Num
+import GHC.IO
+import {-# SOURCE #-} GHC.IO.Exception ( unsupportedOperation )
+
+-- | A low-level I/O provider where the data is bytes in memory.
+class RawIO a where
+ -- | Read up to the specified number of bytes, returning the number
+ -- of bytes actually read. This function should only block if there
+ -- is no data available. If there is not enough data available,
+ -- then the function should just return the available data. A return
+ -- value of zero indicates that the end of the data stream (e.g. end
+ -- of file) has been reached.
+ read :: a -> Ptr Word8 -> Int -> IO Int
+
+ -- | Read up to the specified number of bytes, returning the number
+ -- of bytes actually read, or 'Nothing' if the end of the stream has
+ -- been reached.
+ readNonBlocking :: a -> Ptr Word8 -> Int -> IO (Maybe Int)
+
+ -- | Write the specified number of bytes.
+ write :: a -> Ptr Word8 -> Int -> IO ()
+
+ -- | Write up to the specified number of bytes without blocking. Returns
+ -- the actual number of bytes written.
+ writeNonBlocking :: a -> Ptr Word8 -> Int -> IO Int
+
+
+-- | I/O operations required for implementing a 'Handle'.
+class IODevice a where
+ -- | @ready dev write msecs@ returns 'True' if the device has data
+ -- to read (if @write@ is 'False') or space to write new data (if
+ -- @write@ is 'True'). @msecs@ specifies how long to wait, in
+ -- milliseconds.
+ --
+ ready :: a -> Bool -> Int -> IO Bool
+
+ -- | closes the device. Further operations on the device should
+ -- produce exceptions.
+ close :: a -> IO ()
+
+ -- | returns 'True' if the device is a terminal or console.
+ isTerminal :: a -> IO Bool
+ isTerminal _ = return False
+
+ -- | returns 'True' if the device supports 'seek' operations.
+ isSeekable :: a -> IO Bool
+ isSeekable _ = return False
+
+ -- | seek to the specified positing in the data.
+ seek :: a -> SeekMode -> Integer -> IO ()
+ seek _ _ _ = ioe_unsupportedOperation
+
+ -- | return the current position in the data.
+ tell :: a -> IO Integer
+ tell _ = ioe_unsupportedOperation
+
+ -- | return the size of the data.
+ getSize :: a -> IO Integer
+ getSize _ = ioe_unsupportedOperation
+
+ -- | change the size of the data.
+ setSize :: a -> Integer -> IO ()
+ setSize _ _ = ioe_unsupportedOperation
+
+ -- | for terminal devices, changes whether characters are echoed on
+ -- the device.
+ setEcho :: a -> Bool -> IO ()
+ setEcho _ _ = ioe_unsupportedOperation
+
+ -- | returns the current echoing status.
+ getEcho :: a -> IO Bool
+ getEcho _ = ioe_unsupportedOperation
+
+ -- | some devices (e.g. terminals) support a "raw" mode where
+ -- characters entered are immediately made available to the program.
+ -- If available, this operations enables raw mode.
+ setRaw :: a -> Bool -> IO ()
+ setRaw _ _ = ioe_unsupportedOperation
+
+ -- | returns the 'IODeviceType' corresponding to this device.
+ devType :: a -> IO IODeviceType
+
+ -- | duplicates the device, if possible. The new device is expected
+ -- to share a file pointer with the original device (like Unix @dup@).
+ dup :: a -> IO a
+ dup _ = ioe_unsupportedOperation
+
+ -- | @dup2 source target@ replaces the target device with the source
+ -- device. The target device is closed first, if necessary, and then
+ -- it is made into a duplicate of the first device (like Unix @dup2@).
+ dup2 :: a -> a -> IO a
+ dup2 _ _ = ioe_unsupportedOperation
+
+ioe_unsupportedOperation :: IO a
+ioe_unsupportedOperation = throwIO unsupportedOperation
+
+data IODeviceType
+ = Directory
+ | Stream
+ | RegularFile
+ | RawDevice
+ deriving (Eq)
+
+-- -----------------------------------------------------------------------------
+-- SeekMode type
+
+-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
+data SeekMode
+ = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
+ | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
+ -- from the current position.
+ | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
+ -- from the end of the file.
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Encoding
+-- Copyright : (c) The University of Glasgow, 2008-2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- Text codecs for I/O
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Encoding (
+ BufferCodec(..), TextEncoding(..), TextEncoder, TextDecoder,
+ latin1, latin1_encode, latin1_decode,
+ utf8,
+ utf16, utf16le, utf16be,
+ utf32, utf32le, utf32be,
+ localeEncoding,
+ mkTextEncoding,
+ ) where
+
+import GHC.Base
+import GHC.IO
+import GHC.IO.Buffer
+import GHC.IO.Encoding.Types
+import GHC.Word
+#if !defined(mingw32_HOST_OS)
+import qualified GHC.IO.Encoding.Iconv as Iconv
+#endif
+import qualified GHC.IO.Encoding.Latin1 as Latin1
+import qualified GHC.IO.Encoding.UTF8 as UTF8
+import qualified GHC.IO.Encoding.UTF16 as UTF16
+import qualified GHC.IO.Encoding.UTF32 as UTF32
+
+#if defined(mingw32_HOST_OS)
+import Data.Maybe
+import GHC.IO.Exception
+#endif
+
+-- -----------------------------------------------------------------------------
+
+latin1, utf8, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding
+ :: TextEncoding
+
+-- | The Latin1 (ISO8859-1) encoding. This encoding maps bytes
+-- directly to the first 256 Unicode code points, and is thus not a
+-- complete Unicode encoding.
+latin1 = Latin1.latin1_checked
+
+-- | The UTF-8 unicode encoding
+utf8 = UTF8.utf8
+
+-- | The UTF-16 unicode encoding (a byte-order-mark should be used to
+-- indicate endianness).
+utf16 = UTF16.utf16
+
+-- | The UTF-16 unicode encoding (litte-endian)
+utf16le = UTF16.utf16le
+
+-- | The UTF-16 unicode encoding (big-endian)
+utf16be = UTF16.utf16be
+
+-- | The UTF-32 unicode encoding (a byte-order-mark should be used to
+-- indicate endianness).
+utf32 = UTF32.utf32
+
+-- | The UTF-32 unicode encoding (litte-endian)
+utf32le = UTF32.utf32le
+
+-- | The UTF-32 unicode encoding (big-endian)
+utf32be = UTF32.utf32be
+
+-- | The text encoding of the current locale
+#if !defined(mingw32_HOST_OS)
+localeEncoding = Iconv.localeEncoding
+#else
+localeEncoding = Latin1.latin1
+#endif
+
+-- | Acquire the named text encoding
+mkTextEncoding :: String -> IO TextEncoding
+#if !defined(mingw32_HOST_OS)
+mkTextEncoding = Iconv.mkTextEncoding
+#else
+mkTextEncoding "UTF-8" = return utf8
+mkTextEncoding "UTF-16" = return utf16
+mkTextEncoding "UTF-16LE" = return utf16le
+mkTextEncoding "UTF-16BE" = return utf16be
+mkTextEncoding "UTF-32" = return utf32
+mkTextEncoding "UTF-32LE" = return utf32le
+mkTextEncoding "UTF-32BE" = return utf32be
+mkTextEncoding e = ioException
+ (IOError Nothing InvalidArgument "mkTextEncoding"
+ ("unknown encoding:" ++ e) Nothing Nothing)
+#endif
+
+latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)
+latin1_encode = Latin1.latin1_encode -- unchecked, used for binary
+--latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode
+
+latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)
+latin1_decode = Latin1.latin1_decode
+--latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Encoding.Iconv
+-- Copyright : (c) The University of Glasgow, 2008-2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- This module provides text encoding/decoding using iconv
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC.IO.Encoding.Iconv (
+#if !defined(mingw32_HOST_OS)
+ mkTextEncoding,
+ latin1,
+ utf8,
+ utf16, utf16le, utf16be,
+ utf32, utf32le, utf32be,
+ localeEncoding
+#endif
+ ) where
+
+#if !defined(mingw32_HOST_OS)
+
+#undef DEBUG_DUMP
+
+import Foreign
+import Foreign.C
+import Data.Maybe
+import GHC.Base
+import GHC.Word
+import GHC.IO
+import GHC.IO.Buffer
+import GHC.IO.Encoding.Types
+import GHC.Num
+import GHC.Show
+import GHC.Real
+#ifdef DEBUG_DUMP
+import System.Posix.Internals
+#endif
+
+iconv_trace :: String -> IO ()
+
+#ifdef DEBUG_DUMP
+
+iconv_trace s = puts s
+
+puts :: String -> IO ()
+puts s = do withCStringLen (s++"\n") $ \(p,len) ->
+ c_write 1 p (fromIntegral len)
+ return ()
+
+#else
+
+iconv_trace _ = return ()
+
+#endif
+
+-- -----------------------------------------------------------------------------
+-- iconv encoders/decoders
+
+{-# NOINLINE latin1 #-}
+latin1 :: TextEncoding
+latin1 = unsafePerformIO (mkTextEncoding "Latin1")
+
+{-# NOINLINE utf8 #-}
+utf8 :: TextEncoding
+utf8 = unsafePerformIO (mkTextEncoding "UTF8")
+
+{-# NOINLINE utf16 #-}
+utf16 :: TextEncoding
+utf16 = unsafePerformIO (mkTextEncoding "UTF16")
+
+{-# NOINLINE utf16le #-}
+utf16le :: TextEncoding
+utf16le = unsafePerformIO (mkTextEncoding "UTF16LE")
+
+{-# NOINLINE utf16be #-}
+utf16be :: TextEncoding
+utf16be = unsafePerformIO (mkTextEncoding "UTF16BE")
+
+{-# NOINLINE utf32 #-}
+utf32 :: TextEncoding
+utf32 = unsafePerformIO (mkTextEncoding "UTF32")
+
+{-# NOINLINE utf32le #-}
+utf32le :: TextEncoding
+utf32le = unsafePerformIO (mkTextEncoding "UTF32LE")
+
+{-# NOINLINE utf32be #-}
+utf32be :: TextEncoding
+utf32be = unsafePerformIO (mkTextEncoding "UTF32BE")
+
+{-# NOINLINE localeEncoding #-}
+localeEncoding :: TextEncoding
+localeEncoding = unsafePerformIO (mkTextEncoding "")
+
+-- We hope iconv_t is a storable type. It should be, since it has at least the
+-- value -1, which is a possible return value from iconv_open.
+type IConv = CLong -- ToDo: (#type iconv_t)
+
+foreign import ccall unsafe "iconv_open"
+ iconv_open :: CString -> CString -> IO IConv
+
+foreign import ccall unsafe "iconv_close"
+ iconv_close :: IConv -> IO CInt
+
+foreign import ccall unsafe "iconv"
+ iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize
+ -> IO CSize
+
+haskellChar :: String
+#ifdef WORDS_BIGENDIAN
+haskellChar | charSize == 2 = "UTF16BE"
+ | otherwise = "UCS-4"
+#else
+haskellChar | charSize == 2 = "UTF16LE"
+ | otherwise = "UCS-4LE"
+#endif
+
+char_shift :: Int
+char_shift | charSize == 2 = 1
+ | otherwise = 2
+
+mkTextEncoding :: String -> IO TextEncoding
+mkTextEncoding charset = do
+ return (TextEncoding {
+ mkTextDecoder = newIConv charset haskellChar iconvDecode,
+ mkTextEncoder = newIConv haskellChar charset iconvEncode})
+
+newIConv :: String -> String
+ -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b))
+ -> IO (BufferCodec a b)
+newIConv from to fn =
+ withCString from $ \ from_str ->
+ withCString to $ \ to_str -> do
+ iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ iconv_open to_str from_str
+ let iclose = do throwErrnoIfMinus1 "Iconv.close" $ iconv_close iconvt
+ return ()
+ return BufferCodec{
+ encode = fn iconvt,
+ close = iclose
+ }
+
+iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem
+ -> IO (Buffer Word8, Buffer CharBufElem)
+iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift
+
+iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8
+ -> IO (Buffer CharBufElem, Buffer Word8)
+iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0
+
+iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int
+ -> IO (Buffer a, Buffer b)
+iconvRecode iconv_t
+ input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } iscale
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } oscale
+ = do
+ iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input))
+ iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output))
+ withRawBuffer iraw $ \ piraw -> do
+ withRawBuffer oraw $ \ poraw -> do
+ with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do
+ with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do
+ with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do
+ with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do
+ res <- iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft
+ new_inleft <- peek p_inleft
+ new_outleft <- peek p_outleft
+ let
+ new_inleft' = fromIntegral new_inleft `shiftR` iscale
+ new_outleft' = fromIntegral new_outleft `shiftR` oscale
+ new_input
+ | new_inleft == 0 = input { bufL = 0, bufR = 0 }
+ | otherwise = input { bufL = iw - new_inleft' }
+ new_output = output{ bufR = os - new_outleft' }
+ iconv_trace ("iconv res=" ++ show res)
+ iconv_trace ("iconvRecode after, input=" ++ show (summaryBuffer new_input))
+ iconv_trace ("iconvRecode after, output=" ++ show (summaryBuffer new_output))
+ if (res /= -1)
+ then do -- all input translated
+ return (new_input, new_output)
+ else do
+ errno <- getErrno
+ case errno of
+ e | e == eINVAL
+ || (e == e2BIG || e == eILSEQ) && new_inleft' /= (iw-ir) -> do
+ iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
+ -- Output overflow is relatively harmless, unless
+ -- we made no progress at all.
+ --
+ -- Similarly, we ignore EILSEQ unless we converted no
+ -- characters. Sometimes iconv reports EILSEQ for a
+ -- character in the input even when there is no room
+ -- in the output; in this case we might be about to
+ -- change the encoding anyway, so the following bytes
+ -- could very well be in a different encoding.
+ -- This also helps with pinpointing EILSEQ errors: we
+ -- don't report it until the rest of the characters in
+ -- the buffer have been drained.
+ return (new_input, new_output)
+
+ _other ->
+ throwErrno "iconvRecoder"
+ -- illegal sequence, or some other error
+
+#endif /* !mingw32_HOST_OS */
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Encoding.Latin1
+-- Copyright : (c) The University of Glasgow, 2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- UTF-32 Codecs for the IO library
+--
+-- Portions Copyright : (c) Tom Harper 2008-2009,
+-- (c) Bryan O'Sullivan 2009,
+-- (c) Duncan Coutts 2009
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Encoding.Latin1 (
+ latin1,
+ latin1_checked,
+ latin1_decode,
+ latin1_encode,
+ latin1_checked_encode,
+ ) where
+
+import GHC.Base
+import GHC.Real
+import GHC.Num
+import GHC.IO
+import GHC.IO.Exception
+import GHC.IO.Buffer
+import GHC.IO.Encoding.Types
+import Data.Maybe
+
+-- -----------------------------------------------------------------------------
+-- Latin1
+
+latin1 :: TextEncoding
+latin1 = TextEncoding { mkTextDecoder = latin1_DF,
+ mkTextEncoder = latin1_EF }
+
+latin1_DF :: IO TextDecoder
+latin1_DF = return (BufferCodec latin1_decode (return ()))
+
+latin1_EF :: IO TextEncoder
+latin1_EF = return (BufferCodec latin1_encode (return ()))
+
+latin1_checked :: TextEncoding
+latin1_checked = TextEncoding { mkTextDecoder = latin1_DF,
+ mkTextEncoder = latin1_checked_EF }
+
+latin1_checked_EF :: IO TextEncoder
+latin1_checked_EF = return (BufferCodec latin1_checked_encode (return ()))
+
+
+latin1_decode :: DecodeBuffer
+latin1_decode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ loop !ir !ow
+ | ow >= os || ir >= iw = done ir ow
+ | otherwise = do
+ c0 <- readWord8Buf iraw ir
+ writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
+ loop (ir+1) (ow+1)
+
+ -- lambda-lifted, to avoid thunks being built in the inner-loop:
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ in
+ loop ir0 ow0
+
+latin1_encode :: EncodeBuffer
+latin1_encode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ loop !ir !ow
+ | ow >= os || ir >= iw = done ir ow
+ | otherwise = do
+ (c,ir') <- readCharBuf iraw ir
+ writeWord8Buf oraw ow (fromIntegral (ord c))
+ loop ir' (ow+1)
+ in
+ loop ir0 ow0
+
+latin1_checked_encode :: EncodeBuffer
+latin1_checked_encode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ loop !ir !ow
+ | ow >= os || ir >= iw = done ir ow
+ | otherwise = do
+ (c,ir') <- readCharBuf iraw ir
+ if ord c > 0xff then invalid else do
+ writeWord8Buf oraw ow (fromIntegral (ord c))
+ loop ir' (ow+1)
+ where
+ invalid = if ir > ir0 then done ir ow else ioe_encodingError
+ in
+ loop ir0 ow0
+
+ioe_encodingError :: IO a
+ioe_encodingError = ioException
+ (IOError Nothing InvalidArgument "latin1_checked_encode"
+ "character is out of range for this encoding" Nothing Nothing)
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Encoding.Types
+-- Copyright : (c) The University of Glasgow, 2008-2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- Types for text encoding/decoding
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Encoding.Types (
+ BufferCodec(..),
+ TextEncoding(..),
+ TextEncoder, TextDecoder,
+ EncodeBuffer, DecodeBuffer,
+ ) where
+
+import GHC.Base
+import GHC.Word
+import GHC.IO
+import GHC.IO.Buffer
+
+-- -----------------------------------------------------------------------------
+-- Text encoders/decoders
+
+data BufferCodec from to = BufferCodec {
+ encode :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to),
+ -- ^ The @encode@ function translates elements of the buffer @from@
+ -- to the buffer @to@. It should translate as many elements as possible
+ -- given the sizes of the buffers, including translating zero elements
+ -- if there is either not enough room in @to@, or @from@ does not
+ -- contain a complete multibyte sequence.
+ --
+ -- @encode@ should raise an exception if, and only if, @from@
+ -- begins with an illegal sequence, or the first element of @from@
+ -- is not representable in the encoding of @to@. That is, if any
+ -- elements can be successfully translated before an error is
+ -- encountered, then @encode@ should translate as much as it can
+ -- and not throw an exception. This behaviour is used by the IO
+ -- library in order to report translation errors at the point they
+ -- actually occur, rather than when the buffer is translated.
+ --
+ close :: IO ()
+ -- ^ Resources associated with the encoding may now be released.
+ -- The @encode@ function may not be called again after calling
+ -- @close@.
+ }
+
+type DecodeBuffer = Buffer Word8 -> Buffer Char
+ -> IO (Buffer Word8, Buffer Char)
+
+type EncodeBuffer = Buffer Char -> Buffer Word8
+ -> IO (Buffer Char, Buffer Word8)
+
+type TextDecoder = BufferCodec Word8 CharBufElem
+type TextEncoder = BufferCodec CharBufElem Word8
+
+-- | A 'TextEncoding' is a specification of a conversion scheme
+-- between sequences of bytes and sequences of Unicode characters.
+--
+-- For example, UTF-8 is an encoding of Unicode characters into a sequence
+-- of bytes. The 'TextEncoding' for UTF-8 is 'utf_8'.
+data TextEncoding
+ = TextEncoding {
+ mkTextDecoder :: IO TextDecoder,
+ mkTextEncoder :: IO TextEncoder
+ }
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Encoding.UTF16
+-- Copyright : (c) The University of Glasgow, 2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- UTF-16 Codecs for the IO library
+--
+-- Portions Copyright : (c) Tom Harper 2008-2009,
+-- (c) Bryan O'Sullivan 2009,
+-- (c) Duncan Coutts 2009
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Encoding.UTF16 (
+ utf16,
+ utf16_decode,
+ utf16_encode,
+
+ utf16be,
+ utf16be_decode,
+ utf16be_encode,
+
+ utf16le,
+ utf16le_decode,
+ utf16le_encode,
+ ) where
+
+import GHC.Base
+import GHC.Real
+import GHC.Num
+import GHC.IO
+import GHC.IO.Exception
+import GHC.IO.Buffer
+import GHC.IO.Encoding.Types
+import GHC.Word
+import Data.Bits
+import Data.Maybe
+import GHC.IORef
+
+#if DEBUG
+import System.Posix.Internals
+import Foreign.C
+import GHC.Show
+
+puts :: String -> IO ()
+puts s = do withCStringLen (s++"\n") $ \(p,len) ->
+ c_write 1 p (fromIntegral len)
+ return ()
+#endif
+
+-- -----------------------------------------------------------------------------
+-- The UTF-16 codec: either UTF16BE or UTF16LE with a BOM
+
+utf16 :: TextEncoding
+utf16 = TextEncoding { mkTextDecoder = utf16_DF,
+ mkTextEncoder = utf16_EF }
+
+utf16_DF :: IO TextDecoder
+utf16_DF = do
+ seen_bom <- newIORef Nothing
+ return (BufferCodec (utf16_decode seen_bom) (return ()))
+
+utf16_EF :: IO TextEncoder
+utf16_EF = do
+ done_bom <- newIORef False
+ return (BufferCodec (utf16_encode done_bom) (return ()))
+
+utf16_encode :: IORef Bool -> EncodeBuffer
+utf16_encode done_bom input
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
+ = do
+ b <- readIORef done_bom
+ if b then utf16_native_encode input output
+ else if os - ow < 2
+ then return (input,output)
+ else do
+ writeIORef done_bom True
+ writeWord8Buf oraw ow bom1
+ writeWord8Buf oraw (ow+1) bom2
+ utf16_native_encode input output{ bufR = ow+2 }
+
+utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer
+utf16_decode seen_bom
+ input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ }
+ output
+ = do
+ mb <- readIORef seen_bom
+ case mb of
+ Just decode -> decode input output
+ Nothing ->
+ if iw - ir < 2 then return (input,output) else do
+ c0 <- readWord8Buf iraw ir
+ c1 <- readWord8Buf iraw (ir+1)
+ case () of
+ _ | c0 == bomB && c1 == bomL -> do
+ writeIORef seen_bom (Just utf16be_decode)
+ utf16be_decode input{ bufL= ir+2 } output
+ | c0 == bomL && c1 == bomB -> do
+ writeIORef seen_bom (Just utf16le_decode)
+ utf16le_decode input{ bufL= ir+2 } output
+ | otherwise -> do
+ writeIORef seen_bom (Just utf16_native_decode)
+ utf16_native_decode input output
+
+
+bomB, bomL, bom1, bom2 :: Word8
+bomB = 0xfe
+bomL = 0xff
+
+-- choose UTF-16BE by default for UTF-16 output
+utf16_native_decode :: DecodeBuffer
+utf16_native_decode = utf16be_decode
+
+utf16_native_encode :: EncodeBuffer
+utf16_native_encode = utf16be_encode
+
+bom1 = bomB
+bom2 = bomL
+
+-- -----------------------------------------------------------------------------
+-- UTF16LE and UTF16BE
+
+utf16be :: TextEncoding
+utf16be = TextEncoding { mkTextDecoder = utf16be_DF,
+ mkTextEncoder = utf16be_EF }
+
+utf16be_DF :: IO TextDecoder
+utf16be_DF = return (BufferCodec utf16be_decode (return ()))
+
+utf16be_EF :: IO TextEncoder
+utf16be_EF = return (BufferCodec utf16be_encode (return ()))
+
+
+utf16le :: TextEncoding
+utf16le = TextEncoding { mkTextDecoder = utf16le_DF,
+ mkTextEncoder = utf16le_EF }
+
+utf16le_DF :: IO TextDecoder
+utf16le_DF = return (BufferCodec utf16le_decode (return ()))
+
+utf16le_EF :: IO TextEncoder
+utf16le_EF = return (BufferCodec utf16le_encode (return ()))
+
+
+
+utf16be_decode :: DecodeBuffer
+utf16be_decode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ loop !ir !ow
+ | ow >= os || ir >= iw = done ir ow
+ | ir + 1 == iw = done ir ow
+ | otherwise = do
+ c0 <- readWord8Buf iraw ir
+ c1 <- readWord8Buf iraw (ir+1)
+ let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1
+ if validate1 x1
+ then do writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
+ loop (ir+2) (ow+1)
+ else if iw - ir < 4 then done ir ow else do
+ c2 <- readWord8Buf iraw (ir+2)
+ c3 <- readWord8Buf iraw (ir+3)
+ let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3
+ if not (validate2 x1 x2) then invalid else do
+ writeCharBuf oraw ow (chr2 x1 x2)
+ loop (ir+4) (ow+1)
+ where
+ invalid = if ir > ir0 then done ir ow else ioe_decodingError
+
+ -- lambda-lifted, to avoid thunks being built in the inner-loop:
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ in
+ loop ir0 ow0
+
+utf16le_decode :: DecodeBuffer
+utf16le_decode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ loop !ir !ow
+ | ow >= os || ir >= iw = done ir ow
+ | ir + 1 == iw = done ir ow
+ | otherwise = do
+ c0 <- readWord8Buf iraw ir
+ c1 <- readWord8Buf iraw (ir+1)
+ let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0
+ if validate1 x1
+ then do writeCharBuf oraw ow (unsafeChr (fromIntegral x1))
+ loop (ir+2) (ow+1)
+ else if iw - ir < 4 then done ir ow else do
+ c2 <- readWord8Buf iraw (ir+2)
+ c3 <- readWord8Buf iraw (ir+3)
+ let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2
+ if not (validate2 x1 x2) then invalid else do
+ writeCharBuf oraw ow (chr2 x1 x2)
+ loop (ir+4) (ow+1)
+ where
+ invalid = if ir > ir0 then done ir ow else ioe_decodingError
+
+ -- lambda-lifted, to avoid thunks being built in the inner-loop:
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ in
+ loop ir0 ow0
+
+ioe_decodingError :: IO a
+ioe_decodingError = ioException
+ (IOError Nothing InvalidArgument "utf16_decode"
+ "invalid UTF-16 byte sequence" Nothing Nothing)
+
+utf16be_encode :: EncodeBuffer
+utf16be_encode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ loop !ir !ow
+ | ir >= iw = done ir ow
+ | os - ow < 2 = done ir ow
+ | otherwise = do
+ (c,ir') <- readCharBuf iraw ir
+ case ord c of
+ x | x < 0x10000 -> do
+ writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8))
+ writeWord8Buf oraw (ow+1) (fromIntegral x)
+ loop ir' (ow+2)
+ | otherwise -> do
+ if os - ow < 4 then done ir ow else do
+ let
+ n1 = x - 0x10000
+ c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
+ c2 = fromIntegral (n1 `shiftR` 10)
+ n2 = n1 .&. 0x3FF
+ c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
+ c4 = fromIntegral n2
+ --
+ writeWord8Buf oraw ow c1
+ writeWord8Buf oraw (ow+1) c2
+ writeWord8Buf oraw (ow+2) c3
+ writeWord8Buf oraw (ow+3) c4
+ loop ir' (ow+4)
+ in
+ loop ir0 ow0
+
+utf16le_encode :: EncodeBuffer
+utf16le_encode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ loop !ir !ow
+ | ir >= iw = done ir ow
+ | os - ow < 2 = done ir ow
+ | otherwise = do
+ (c,ir') <- readCharBuf iraw ir
+ case ord c of
+ x | x < 0x10000 -> do
+ writeWord8Buf oraw ow (fromIntegral x)
+ writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8))
+ loop ir' (ow+2)
+ | otherwise ->
+ if os - ow < 4 then done ir ow else do
+ let
+ n1 = x - 0x10000
+ c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
+ c2 = fromIntegral (n1 `shiftR` 10)
+ n2 = n1 .&. 0x3FF
+ c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
+ c4 = fromIntegral n2
+ --
+ writeWord8Buf oraw ow c2
+ writeWord8Buf oraw (ow+1) c1
+ writeWord8Buf oraw (ow+2) c4
+ writeWord8Buf oraw (ow+3) c3
+ loop ir' (ow+4)
+ in
+ loop ir0 ow0
+
+chr2 :: Word16 -> Word16 -> Char
+chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#))
+ where
+ !x# = word2Int# a#
+ !y# = word2Int# b#
+ !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10#
+ !lower# = y# -# 0xDC00#
+{-# INLINE chr2 #-}
+
+validate1 :: Word16 -> Bool
+validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF
+{-# INLINE validate1 #-}
+
+validate2 :: Word16 -> Word16 -> Bool
+validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF &&
+ x2 >= 0xDC00 && x2 <= 0xDFFF
+{-# INLINE validate2 #-}
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Encoding.UTF32
+-- Copyright : (c) The University of Glasgow, 2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- UTF-32 Codecs for the IO library
+--
+-- Portions Copyright : (c) Tom Harper 2008-2009,
+-- (c) Bryan O'Sullivan 2009,
+-- (c) Duncan Coutts 2009
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Encoding.UTF32 (
+ utf32,
+ utf32_decode,
+ utf32_encode,
+
+ utf32be,
+ utf32be_decode,
+ utf32be_encode,
+
+ utf32le,
+ utf32le_decode,
+ utf32le_encode,
+ ) where
+
+import GHC.Base
+import GHC.Real
+import GHC.Num
+import GHC.IO
+import GHC.IO.Exception
+import GHC.IO.Buffer
+import GHC.IO.Encoding.Types
+import GHC.Word
+import Data.Bits
+import Data.Maybe
+import GHC.IORef
+
+-- -----------------------------------------------------------------------------
+-- The UTF-32 codec: either UTF-32BE or UTF-32LE with a BOM
+
+utf32 :: TextEncoding
+utf32 = TextEncoding { mkTextDecoder = utf32_DF,
+ mkTextEncoder = utf32_EF }
+
+utf32_DF :: IO TextDecoder
+utf32_DF = do
+ seen_bom <- newIORef Nothing
+ return (BufferCodec (utf32_decode seen_bom) (return ()))
+
+utf32_EF :: IO TextEncoder
+utf32_EF = do
+ done_bom <- newIORef False
+ return (BufferCodec (utf32_encode done_bom) (return ()))
+
+utf32_encode :: IORef Bool -> EncodeBuffer
+utf32_encode done_bom input
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
+ = do
+ b <- readIORef done_bom
+ if b then utf32_native_encode input output
+ else if os - ow < 4
+ then return (input,output)
+ else do
+ writeIORef done_bom True
+ writeWord8Buf oraw ow bom0
+ writeWord8Buf oraw (ow+1) bom1
+ writeWord8Buf oraw (ow+2) bom2
+ writeWord8Buf oraw (ow+3) bom3
+ utf32_native_encode input output{ bufR = ow+4 }
+
+utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer
+utf32_decode seen_bom
+ input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ }
+ output
+ = do
+ mb <- readIORef seen_bom
+ case mb of
+ Just decode -> decode input output
+ Nothing ->
+ if iw - ir < 4 then return (input,output) else do
+ c0 <- readWord8Buf iraw ir
+ c1 <- readWord8Buf iraw (ir+1)
+ c2 <- readWord8Buf iraw (ir+2)
+ c3 <- readWord8Buf iraw (ir+3)
+ case () of
+ _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do
+ writeIORef seen_bom (Just utf32be_decode)
+ utf32be_decode input{ bufL= ir+4 } output
+ _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do
+ writeIORef seen_bom (Just utf32le_decode)
+ utf32le_decode input{ bufL= ir+4 } output
+ | otherwise -> do
+ writeIORef seen_bom (Just utf32_native_decode)
+ utf32_native_decode input output
+
+
+bom0, bom1, bom2, bom3 :: Word8
+bom0 = 0
+bom1 = 0
+bom2 = 0xfe
+bom3 = 0xff
+
+-- choose UTF-32BE by default for UTF-32 output
+utf32_native_decode :: DecodeBuffer
+utf32_native_decode = utf32be_decode
+
+utf32_native_encode :: EncodeBuffer
+utf32_native_encode = utf32be_encode
+
+-- -----------------------------------------------------------------------------
+-- UTF32LE and UTF32BE
+
+utf32be :: TextEncoding
+utf32be = TextEncoding { mkTextDecoder = utf32be_DF,
+ mkTextEncoder = utf32be_EF }
+
+utf32be_DF :: IO TextDecoder
+utf32be_DF = return (BufferCodec utf32be_decode (return ()))
+
+utf32be_EF :: IO TextEncoder
+utf32be_EF = return (BufferCodec utf32be_encode (return ()))
+
+
+utf32le :: TextEncoding
+utf32le = TextEncoding { mkTextDecoder = utf32le_DF,
+ mkTextEncoder = utf32le_EF }
+
+utf32le_DF :: IO TextDecoder
+utf32le_DF = return (BufferCodec utf32le_decode (return ()))
+
+utf32le_EF :: IO TextEncoder
+utf32le_EF = return (BufferCodec utf32le_encode (return ()))
+
+
+
+utf32be_decode :: DecodeBuffer
+utf32be_decode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ loop !ir !ow
+ | ow >= os || iw - ir < 4 = done ir ow
+ | otherwise = do
+ c0 <- readWord8Buf iraw ir
+ c1 <- readWord8Buf iraw (ir+1)
+ c2 <- readWord8Buf iraw (ir+2)
+ c3 <- readWord8Buf iraw (ir+3)
+ let x1 = chr4 c0 c1 c2 c3
+ if not (validate x1) then invalid else do
+ writeCharBuf oraw ow x1
+ loop (ir+4) (ow+1)
+ where
+ invalid = if ir > ir0 then done ir ow else ioe_decodingError
+
+ -- lambda-lifted, to avoid thunks being built in the inner-loop:
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ in
+ loop ir0 ow0
+
+utf32le_decode :: DecodeBuffer
+utf32le_decode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ loop !ir !ow
+ | ow >= os || iw - ir < 4 = done ir ow
+ | otherwise = do
+ c0 <- readWord8Buf iraw ir
+ c1 <- readWord8Buf iraw (ir+1)
+ c2 <- readWord8Buf iraw (ir+2)
+ c3 <- readWord8Buf iraw (ir+3)
+ let x1 = chr4 c3 c2 c1 c0
+ if not (validate x1) then invalid else do
+ writeCharBuf oraw ow x1
+ loop (ir+4) (ow+1)
+ where
+ invalid = if ir > ir0 then done ir ow else ioe_decodingError
+
+ -- lambda-lifted, to avoid thunks being built in the inner-loop:
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ in
+ loop ir0 ow0
+
+ioe_decodingError :: IO a
+ioe_decodingError = ioException
+ (IOError Nothing InvalidArgument "utf32_decode"
+ "invalid UTF-32 byte sequence" Nothing Nothing)
+
+utf32be_encode :: EncodeBuffer
+utf32be_encode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ loop !ir !ow
+ | ir >= iw = done ir ow
+ | os - ow < 4 = done ir ow
+ | otherwise = do
+ (c,ir') <- readCharBuf iraw ir
+ let (c0,c1,c2,c3) = ord4 c
+ writeWord8Buf oraw ow c0
+ writeWord8Buf oraw (ow+1) c1
+ writeWord8Buf oraw (ow+2) c2
+ writeWord8Buf oraw (ow+3) c3
+ loop ir' (ow+4)
+ in
+ loop ir0 ow0
+
+utf32le_encode :: EncodeBuffer
+utf32le_encode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ loop !ir !ow
+ | ir >= iw = done ir ow
+ | os - ow < 4 = done ir ow
+ | otherwise = do
+ (c,ir') <- readCharBuf iraw ir
+ let (c0,c1,c2,c3) = ord4 c
+ writeWord8Buf oraw ow c3
+ writeWord8Buf oraw (ow+1) c2
+ writeWord8Buf oraw (ow+2) c1
+ writeWord8Buf oraw (ow+3) c0
+ loop ir' (ow+4)
+ in
+ loop ir0 ow0
+
+chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
+chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
+ C# (chr# (z1# +# z2# +# z3# +# z4#))
+ where
+ !y1# = word2Int# x1#
+ !y2# = word2Int# x2#
+ !y3# = word2Int# x3#
+ !y4# = word2Int# x4#
+ !z1# = uncheckedIShiftL# y1# 24#
+ !z2# = uncheckedIShiftL# y2# 16#
+ !z3# = uncheckedIShiftL# y3# 8#
+ !z4# = y4#
+{-# INLINE chr4 #-}
+
+ord4 :: Char -> (Word8,Word8,Word8,Word8)
+ord4 c = (fromIntegral (x `shiftR` 24),
+ fromIntegral (x `shiftR` 16),
+ fromIntegral (x `shiftR` 8),
+ fromIntegral x)
+ where
+ x = ord c
+{-# INLINE ord4 #-}
+
+
+validate :: Char -> Bool
+validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)
+ where x1 = ord c
+{-# INLINE validate #-}
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Encoding.UTF8
+-- Copyright : (c) The University of Glasgow, 2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- UTF-8 Codec for the IO library
+--
+-- Portions Copyright : (c) Tom Harper 2008-2009,
+-- (c) Bryan O'Sullivan 2009,
+-- (c) Duncan Coutts 2009
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Encoding.UTF8 (
+ utf8,
+ utf8_decode,
+ utf8_encode,
+ ) where
+
+import GHC.Base
+import GHC.Real
+import GHC.Num
+import GHC.IO
+import GHC.IO.Exception
+import GHC.IO.Buffer
+import GHC.IO.Encoding.Types
+import GHC.Word
+import Data.Bits
+import Data.Maybe
+
+utf8 :: TextEncoding
+utf8 = TextEncoding { mkTextDecoder = utf8_DF,
+ mkTextEncoder = utf8_EF }
+
+utf8_DF :: IO TextDecoder
+utf8_DF = return (BufferCodec utf8_decode (return ()))
+
+utf8_EF :: IO TextEncoder
+utf8_EF = return (BufferCodec utf8_encode (return ()))
+
+utf8_decode :: DecodeBuffer
+utf8_decode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ loop !ir !ow
+ | ow >= os || ir >= iw = done ir ow
+ | otherwise = do
+ c0 <- readWord8Buf iraw ir
+ case c0 of
+ _ | c0 <= 0x7f -> do
+ writeCharBuf oraw ow (unsafeChr (fromIntegral c0))
+ loop (ir+1) (ow+1)
+ | c0 >= 0xc0 && c0 <= 0xdf ->
+ if iw - ir < 2 then done ir ow else do
+ c1 <- readWord8Buf iraw (ir+1)
+ if (c1 < 0x80 || c1 >= 0xc0) then invalid else do
+ writeCharBuf oraw ow (chr2 c0 c1)
+ loop (ir+2) (ow+1)
+ | c0 >= 0xe0 && c0 <= 0xef ->
+ if iw - ir < 3 then done ir ow else do
+ c1 <- readWord8Buf iraw (ir+1)
+ c2 <- readWord8Buf iraw (ir+2)
+ if not (validate3 c0 c1 c2) then invalid else do
+ writeCharBuf oraw ow (chr3 c0 c1 c2)
+ loop (ir+3) (ow+1)
+ | otherwise ->
+ if iw - ir < 4 then done ir ow else do
+ c1 <- readWord8Buf iraw (ir+1)
+ c2 <- readWord8Buf iraw (ir+2)
+ c3 <- readWord8Buf iraw (ir+3)
+ if not (validate4 c0 c1 c2 c3) then invalid else do
+ writeCharBuf oraw ow (chr4 c0 c1 c2 c3)
+ loop (ir+4) (ow+1)
+ where
+ invalid = if ir > ir0 then done ir ow else ioe_decodingError
+
+ -- lambda-lifted, to avoid thunks being built in the inner-loop:
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ in
+ loop ir0 ow0
+
+ioe_decodingError :: IO a
+ioe_decodingError = ioException
+ (IOError Nothing InvalidArgument "utf8_decode"
+ "invalid UTF-8 byte sequence" Nothing Nothing)
+
+utf8_encode :: EncodeBuffer
+utf8_encode
+ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
+ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
+ = let
+ done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
+ else input{ bufL=ir },
+ output{ bufR=ow })
+ loop !ir !ow
+ | ow >= os || ir >= iw = done ir ow
+ | otherwise = do
+ (c,ir') <- readCharBuf iraw ir
+ case ord c of
+ x | x <= 0x7F -> do
+ writeWord8Buf oraw ow (fromIntegral x)
+ loop ir' (ow+1)
+ | x <= 0x07FF ->
+ if os - ow < 2 then done ir ow else do
+ let (c1,c2) = ord2 c
+ writeWord8Buf oraw ow c1
+ writeWord8Buf oraw (ow+1) c2
+ loop ir' (ow+2)
+ | x <= 0xFFFF -> do
+ if os - ow < 3 then done ir ow else do
+ let (c1,c2,c3) = ord3 c
+ writeWord8Buf oraw ow c1
+ writeWord8Buf oraw (ow+1) c2
+ writeWord8Buf oraw (ow+2) c3
+ loop ir' (ow+3)
+ | otherwise -> do
+ if os - ow < 4 then done ir ow else do
+ let (c1,c2,c3,c4) = ord4 c
+ writeWord8Buf oraw ow c1
+ writeWord8Buf oraw (ow+1) c2
+ writeWord8Buf oraw (ow+2) c3
+ writeWord8Buf oraw (ow+3) c4
+ loop ir' (ow+4)
+ in
+ loop ir0 ow0
+
+-- -----------------------------------------------------------------------------
+-- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8
+
+ord2 :: Char -> (Word8,Word8)
+ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)
+ where
+ n = ord c
+ x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
+ x2 = fromIntegral $ (n .&. 0x3F) + 0x80
+
+ord3 :: Char -> (Word8,Word8,Word8)
+ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)
+ where
+ n = ord c
+ x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
+ x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
+ x3 = fromIntegral $ (n .&. 0x3F) + 0x80
+
+ord4 :: Char -> (Word8,Word8,Word8,Word8)
+ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)
+ where
+ n = ord c
+ x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
+ x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
+ x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
+ x4 = fromIntegral $ (n .&. 0x3F) + 0x80
+
+chr2 :: Word8 -> Word8 -> Char
+chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
+ where
+ !y1# = word2Int# x1#
+ !y2# = word2Int# x2#
+ !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6#
+ !z2# = y2# -# 0x80#
+{-# INLINE chr2 #-}
+
+chr3 :: Word8 -> Word8 -> Word8 -> Char
+chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
+ where
+ !y1# = word2Int# x1#
+ !y2# = word2Int# x2#
+ !y3# = word2Int# x3#
+ !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12#
+ !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6#
+ !z3# = y3# -# 0x80#
+{-# INLINE chr3 #-}
+
+chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
+chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
+ C# (chr# (z1# +# z2# +# z3# +# z4#))
+ where
+ !y1# = word2Int# x1#
+ !y2# = word2Int# x2#
+ !y3# = word2Int# x3#
+ !y4# = word2Int# x4#
+ !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18#
+ !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12#
+ !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#
+ !z4# = y4# -# 0x80#
+{-# INLINE chr4 #-}
+
+between :: Word8 -- ^ byte to check
+ -> Word8 -- ^ lower bound
+ -> Word8 -- ^ upper bound
+ -> Bool
+between x y z = x >= y && x <= z
+{-# INLINE between #-}
+
+validate3 :: Word8 -> Word8 -> Word8 -> Bool
+{-# INLINE validate3 #-}
+validate3 x1 x2 x3 = validate3_1 ||
+ validate3_2 ||
+ validate3_3 ||
+ validate3_4
+ where
+ validate3_1 = (x1 == 0xE0) &&
+ between x2 0xA0 0xBF &&
+ between x3 0x80 0xBF
+ validate3_2 = between x1 0xE1 0xEC &&
+ between x2 0x80 0xBF &&
+ between x3 0x80 0xBF
+ validate3_3 = x1 == 0xED &&
+ between x2 0x80 0x9F &&
+ between x3 0x80 0xBF
+ validate3_4 = between x1 0xEE 0xEF &&
+ between x2 0x80 0xBF &&
+ between x3 0x80 0xBF
+
+validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
+{-# INLINE validate4 #-}
+validate4 x1 x2 x3 x4 = validate4_1 ||
+ validate4_2 ||
+ validate4_3
+ where
+ validate4_1 = x1 == 0xF0 &&
+ between x2 0x90 0xBF &&
+ between x3 0x80 0xBF &&
+ between x4 0x80 0xBF
+ validate4_2 = between x1 0xF1 0xF3 &&
+ between x2 0x80 0xBF &&
+ between x3 0x80 0xBF &&
+ between x4 0x80 0xBF
+ validate4_3 = x1 == 0xF4 &&
+ between x2 0x80 0x8F &&
+ between x3 0x80 0xBF &&
+ between x4 0x80 0xBF
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Exception
+-- Copyright : (c) The University of Glasgow, 2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- IO-related Exception types and functions
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Exception (
+ BlockedOnDeadMVar(..), blockedOnDeadMVar,
+ BlockedIndefinitely(..), blockedIndefinitely,
+ Deadlock(..),
+ AssertionFailed(..),
+ AsyncException(..), stackOverflow, heapOverflow,
+ ArrayException(..),
+ ExitCode(..),
+
+ ioException,
+ ioError,
+ IOError,
+ IOException(..),
+ IOErrorType(..),
+ userError,
+ assertError,
+ unsupportedOperation,
+ untangle,
+ ) where
+
+import GHC.Base
+import GHC.List
+import GHC.IO
+import GHC.Show
+import GHC.Read
+import GHC.Exception
+import Data.Maybe
+import GHC.IO.Handle.Types
+import Foreign.C.Types
+
+import Data.Typeable ( Typeable )
+
+-- ------------------------------------------------------------------------
+-- Exception datatypes and operations
+
+-- |The thread is blocked on an @MVar@, but there are no other references
+-- to the @MVar@ so it can't ever continue.
+data BlockedOnDeadMVar = BlockedOnDeadMVar
+ deriving Typeable
+
+instance Exception BlockedOnDeadMVar
+
+instance Show BlockedOnDeadMVar where
+ showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
+
+blockedOnDeadMVar :: SomeException -- for the RTS
+blockedOnDeadMVar = toException BlockedOnDeadMVar
+
+-----
+
+-- |The thread is awiting to retry an STM transaction, but there are no
+-- other references to any @TVar@s involved, so it can't ever continue.
+data BlockedIndefinitely = BlockedIndefinitely
+ deriving Typeable
+
+instance Exception BlockedIndefinitely
+
+instance Show BlockedIndefinitely where
+ showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
+
+blockedIndefinitely :: SomeException -- for the RTS
+blockedIndefinitely = toException BlockedIndefinitely
+
+-----
+
+-- |There are no runnable threads, so the program is deadlocked.
+-- The @Deadlock@ exception is raised in the main thread only.
+data Deadlock = Deadlock
+ deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+ showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
+-- |There are no runnable threads, so the program is deadlocked.
+-- The @Deadlock@ exception is raised in the main thread only.
+data AssertionFailed = AssertionFailed String
+ deriving Typeable
+
+instance Exception AssertionFailed
+
+instance Show AssertionFailed where
+ showsPrec _ (AssertionFailed err) = showString err
+
+-----
+
+-- |Asynchronous exceptions.
+data AsyncException
+ = StackOverflow
+ -- ^The current thread\'s stack exceeded its limit.
+ -- Since an exception has been raised, the thread\'s stack
+ -- will certainly be below its limit again, but the
+ -- programmer should take remedial action
+ -- immediately.
+ | HeapOverflow
+ -- ^The program\'s heap is reaching its limit, and
+ -- the program should take action to reduce the amount of
+ -- live data it has. Notes:
+ --
+ -- * It is undefined which thread receives this exception.
+ --
+ -- * GHC currently does not throw 'HeapOverflow' exceptions.
+ | ThreadKilled
+ -- ^This exception is raised by another thread
+ -- calling 'Control.Concurrent.killThread', or by the system
+ -- if it needs to terminate the thread for some
+ -- reason.
+ | UserInterrupt
+ -- ^This exception is raised by default in the main thread of
+ -- the program when the user requests to terminate the program
+ -- via the usual mechanism(s) (e.g. Control-C in the console).
+ deriving (Eq, Ord, Typeable)
+
+instance Exception AsyncException
+
+-- | Exceptions generated by array operations
+data ArrayException
+ = IndexOutOfBounds String
+ -- ^An attempt was made to index an array outside
+ -- its declared bounds.
+ | UndefinedElement String
+ -- ^An attempt was made to evaluate an element of an
+ -- array that had not been initialized.
+ deriving (Eq, Ord, Typeable)
+
+instance Exception ArrayException
+
+stackOverflow, heapOverflow :: SomeException -- for the RTS
+stackOverflow = toException StackOverflow
+heapOverflow = toException HeapOverflow
+
+instance Show AsyncException where
+ showsPrec _ StackOverflow = showString "stack overflow"
+ showsPrec _ HeapOverflow = showString "heap overflow"
+ showsPrec _ ThreadKilled = showString "thread killed"
+ showsPrec _ UserInterrupt = showString "user interrupt"
+
+instance Show ArrayException where
+ showsPrec _ (IndexOutOfBounds s)
+ = showString "array index out of range"
+ . (if not (null s) then showString ": " . showString s
+ else id)
+ showsPrec _ (UndefinedElement s)
+ = showString "undefined array element"
+ . (if not (null s) then showString ": " . showString s
+ else id)
+
+-- -----------------------------------------------------------------------------
+-- The ExitCode type
+
+-- We need it here because it is used in ExitException in the
+-- Exception datatype (above).
+
+data ExitCode
+ = ExitSuccess -- ^ indicates successful termination;
+ | ExitFailure Int
+ -- ^ indicates program failure with an exit code.
+ -- The exact interpretation of the code is
+ -- operating-system dependent. In particular, some values
+ -- may be prohibited (e.g. 0 on a POSIX-compliant system).
+ deriving (Eq, Ord, Read, Show, Typeable)
+
+instance Exception ExitCode
+
+ioException :: IOException -> IO a
+ioException err = throwIO err
+
+-- | Raise an 'IOError' in the 'IO' monad.
+ioError :: IOError -> IO a
+ioError = ioException
+
+-- ---------------------------------------------------------------------------
+-- IOError type
+
+-- | The Haskell 98 type for exceptions in the 'IO' monad.
+-- Any I\/O operation may raise an 'IOError' instead of returning a result.
+-- For a more general type of exception, including also those that arise
+-- in pure code, see 'Control.Exception.Exception'.
+--
+-- In Haskell 98, this is an opaque type.
+type IOError = IOException
+
+-- |Exceptions that occur in the @IO@ monad.
+-- An @IOException@ records a more specific error type, a descriptive
+-- string and maybe the handle that was used when the error was
+-- flagged.
+data IOException
+ = IOError {
+ ioe_handle :: Maybe Handle, -- the handle used by the action flagging
+ -- the error.
+ ioe_type :: IOErrorType, -- what it was.
+ ioe_location :: String, -- location.
+ ioe_description :: String, -- error type specific information.
+ ioe_errno :: Maybe CInt, -- errno leading to this error, if any.
+ ioe_filename :: Maybe FilePath -- filename the error is related to.
+ }
+ deriving Typeable
+
+instance Exception IOException
+
+instance Eq IOException where
+ (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) =
+ e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2
+
+-- | An abstract type that contains a value for each variant of 'IOError'.
+data IOErrorType
+ -- Haskell 98:
+ = AlreadyExists
+ | NoSuchThing
+ | ResourceBusy
+ | ResourceExhausted
+ | EOF
+ | IllegalOperation
+ | PermissionDenied
+ | UserError
+ -- GHC only:
+ | UnsatisfiedConstraints
+ | SystemError
+ | ProtocolError
+ | OtherError
+ | InvalidArgument
+ | InappropriateType
+ | HardwareFault
+ | UnsupportedOperation
+ | TimeExpired
+ | ResourceVanished
+ | Interrupted
+
+instance Eq IOErrorType where
+ x == y = getTag x ==# getTag y
+
+instance Show IOErrorType where
+ showsPrec _ e =
+ showString $
+ case e of
+ AlreadyExists -> "already exists"
+ NoSuchThing -> "does not exist"
+ ResourceBusy -> "resource busy"
+ ResourceExhausted -> "resource exhausted"
+ EOF -> "end of file"
+ IllegalOperation -> "illegal operation"
+ PermissionDenied -> "permission denied"
+ UserError -> "user error"
+ HardwareFault -> "hardware fault"
+ InappropriateType -> "inappropriate type"
+ Interrupted -> "interrupted"
+ InvalidArgument -> "invalid argument"
+ OtherError -> "failed"
+ ProtocolError -> "protocol error"
+ ResourceVanished -> "resource vanished"
+ SystemError -> "system error"
+ TimeExpired -> "timeout"
+ UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
+ UnsupportedOperation -> "unsupported operation"
+
+-- | Construct an 'IOError' value with a string describing the error.
+-- The 'fail' method of the 'IO' instance of the 'Monad' class raises a
+-- 'userError', thus:
+--
+-- > instance Monad IO where
+-- > ...
+-- > fail s = ioError (userError s)
+--
+userError :: String -> IOError
+userError str = IOError Nothing UserError "" str Nothing Nothing
+
+-- ---------------------------------------------------------------------------
+-- Showing IOErrors
+
+instance Show IOException where
+ showsPrec p (IOError hdl iot loc s _ fn) =
+ (case fn of
+ Nothing -> case hdl of
+ Nothing -> id
+ Just h -> showsPrec p h . showString ": "
+ Just name -> showString name . showString ": ") .
+ (case loc of
+ "" -> id
+ _ -> showString loc . showString ": ") .
+ showsPrec p iot .
+ (case s of
+ "" -> id
+ _ -> showString " (" . showString s . showString ")")
+
+assertError :: Addr# -> Bool -> a -> a
+assertError str predicate v
+ | predicate = v
+ | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+
+unsupportedOperation :: IOError
+unsupportedOperation =
+ (IOError Nothing UnsupportedOperation ""
+ "Operation is not supported" Nothing Nothing)
+
+{-
+(untangle coded message) expects "coded" to be of the form
+ "location|details"
+It prints
+ location message details
+-}
+untangle :: Addr# -> String -> String
+untangle coded message
+ = location
+ ++ ": "
+ ++ message
+ ++ details
+ ++ "\n"
+ where
+ coded_str = unpackCStringUtf8# coded
+
+ (location, details)
+ = case (span not_bar coded_str) of { (loc, rest) ->
+ case rest of
+ ('|':det) -> (loc, ' ' : det)
+ _ -> (loc, "")
+ }
+ not_bar c = c /= '|'
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+module GHC.IO.Exception where
+
+import GHC.Base
+import GHC.Exception
+
+data IOException
+instance Exception IOException
+
+type IOError = IOException
+userError :: String -> IOError
+unsupportedOperation :: IOError
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.FD
+-- Copyright : (c) The University of Glasgow, 1994-2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- Raw read/write operations on file descriptors
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.FD (
+ FD(..),
+ openFile, mkFD, release,
+ setNonBlockingMode,
+ readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,
+ stdin, stdout, stderr
+ ) where
+
+#undef DEBUG_DUMP
+
+import GHC.Base
+import GHC.Num
+import GHC.Real
+import GHC.Show
+import GHC.Enum
+import Data.Maybe
+import Control.Monad
+import Data.Typeable
+
+import GHC.IO
+import GHC.IO.IOMode
+import GHC.IO.Buffer
+import GHC.IO.BufferedIO
+import qualified GHC.IO.Device
+import GHC.IO.Device (SeekMode(..), IODeviceType(..))
+import GHC.Conc
+import GHC.IO.Exception
+
+import Foreign
+import Foreign.C
+import qualified System.Posix.Internals
+import System.Posix.Internals hiding (FD, setEcho, getEcho)
+import System.Posix.Types
+import GHC.Ptr
+
+-- -----------------------------------------------------------------------------
+-- The file-descriptor IO device
+
+data FD = FD {
+ fdFD :: {-# UNPACK #-} !CInt,
+#ifdef mingw32_HOST_OS
+ -- On Windows, a socket file descriptor needs to be read and written
+ -- using different functions (send/recv).
+ fdIsSocket_ :: {-# UNPACK #-} !Int
+#else
+ -- On Unix we need to know whether this FD has O_NONBLOCK set.
+ -- If it has, then we can use more efficient routines to read/write to it.
+ -- It is always safe for this to be off.
+ fdIsNonBlocking :: {-# UNPACK #-} !Int
+#endif
+ }
+ deriving Typeable
+
+#ifdef mingw32_HOST_OS
+fdIsSocket :: FD -> Bool
+fdIsSocket fd = fdIsSocket_ fd /= 0
+#endif
+
+instance Show FD where
+ show fd = show (fdFD fd)
+
+instance GHC.IO.Device.RawIO FD where
+ read = fdRead
+ readNonBlocking = fdReadNonBlocking
+ write = fdWrite
+ writeNonBlocking = fdWriteNonBlocking
+
+instance GHC.IO.Device.IODevice FD where
+ ready = ready
+ close = close
+ isTerminal = isTerminal
+ isSeekable = isSeekable
+ seek = seek
+ tell = tell
+ getSize = getSize
+ setSize = setSize
+ setEcho = setEcho
+ getEcho = getEcho
+ setRaw = setRaw
+ devType = devType
+ dup = dup
+ dup2 = dup2
+
+instance BufferedIO FD where
+ newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
+ fillReadBuffer fd buf = readBuf' fd buf
+ fillReadBuffer0 fd buf = readBufNonBlocking fd buf
+ flushWriteBuffer fd buf = writeBuf' fd buf
+ flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf
+
+readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
+readBuf' fd buf = do
+#ifdef DEBUG_DUMP
+ puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
+#endif
+ (r,buf') <- readBuf fd buf
+#ifdef DEBUG_DUMP
+ puts ("after: " ++ summaryBuffer buf' ++ "\n")
+#endif
+ return (r,buf')
+
+writeBuf' :: FD -> Buffer Word8 -> IO ()
+writeBuf' fd buf = do
+#ifdef DEBUG_DUMP
+ puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
+#endif
+ writeBuf fd buf
+
+-- -----------------------------------------------------------------------------
+-- opening files
+
+-- | Open a file and make an 'FD' for it. Truncates the file to zero
+-- size when the `IOMode` is `WriteMode`. Puts the file descriptor
+-- into non-blocking mode on Unix systems.
+openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
+openFile filepath iomode =
+ withCString filepath $ \ f ->
+
+ let
+ oflags1 = case iomode of
+ ReadMode -> read_flags
+#ifdef mingw32_HOST_OS
+ WriteMode -> write_flags .|. o_TRUNC
+#else
+ WriteMode -> write_flags
+#endif
+ ReadWriteMode -> rw_flags
+ AppendMode -> append_flags
+
+#ifdef mingw32_HOST_OS
+ binary_flags = o_BINARY
+#else
+ binary_flags = 0
+#endif
+
+ oflags = oflags1 .|. binary_flags
+ in do
+
+ -- the old implementation had a complicated series of three opens,
+ -- which is perhaps because we have to be careful not to open
+ -- directories. However, the man pages I've read say that open()
+ -- always returns EISDIR if the file is a directory and was opened
+ -- for writing, so I think we're ok with a single open() here...
+ fd <- throwErrnoIfMinus1Retry "openFile"
+ (c_open f (fromIntegral oflags) 0o666)
+
+ (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
+ False{-not a socket-}
+ True{-is non-blocking-}
+ `catchAny` \e -> do c_close fd; throwIO e
+
+#ifndef mingw32_HOST_OS
+ -- we want to truncate() if this is an open in WriteMode, but only
+ -- if the target is a RegularFile. ftruncate() fails on special files
+ -- like /dev/null.
+ if iomode == WriteMode && fd_type == RegularFile
+ then setSize fD 0
+ else return ()
+#endif
+
+ return (fD,fd_type)
+
+std_flags, output_flags, read_flags, write_flags, rw_flags,
+ append_flags :: CInt
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+read_flags = std_flags .|. o_RDONLY
+write_flags = output_flags .|. o_WRONLY
+rw_flags = output_flags .|. o_RDWR
+append_flags = write_flags .|. o_APPEND
+
+
+-- | Make a 'FD' from an existing file descriptor. Fails if the FD
+-- refers to a directory. If the FD refers to a file, `mkFD` locks
+-- the file according to the Haskell 98 single writer/multiple reader
+-- locking semantics (this is why we need the `IOMode` argument too).
+mkFD :: CInt
+ -> IOMode
+ -> Maybe (IODeviceType, CDev, CIno)
+ -- the results of fdStat if we already know them, or we want
+ -- to prevent fdToHandle_stat from doing its own stat.
+ -- These are used for:
+ -- - we fail if the FD refers to a directory
+ -- - if the FD refers to a file, we lock it using (cdev,cino)
+ -> Bool -- ^ is a socket (on Windows)
+ -> Bool -- ^ is in non-blocking mode on Unix
+ -> IO (FD,IODeviceType)
+
+mkFD fd iomode mb_stat is_socket is_nonblock = do
+
+ let _ = (is_socket, is_nonblock) -- warning suppression
+
+ (fd_type,dev,ino) <-
+ case mb_stat of
+ Nothing -> fdStat fd
+ Just stat -> return stat
+
+ let write = case iomode of
+ ReadMode -> False
+ _ -> True
+
+#ifdef mingw32_HOST_OS
+ let _ = (dev,ino,write,fd) -- warning suppression
+#endif
+
+ case fd_type of
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing Nothing)
+
+#ifndef mingw32_HOST_OS
+ -- regular files need to be locked
+ RegularFile -> do
+ -- On Windows we use explicit exclusion via sopen() to implement
+ -- this locking (see __hscore_open()); on Unix we have to
+ -- implment it in the RTS.
+ r <- lockFile fd dev ino (fromBool write)
+ when (r == -1) $
+ ioException (IOError Nothing ResourceBusy "openFile"
+ "file is locked" Nothing Nothing)
+#endif
+
+ _other_type -> return ()
+
+ return (FD{ fdFD = fd,
+#ifndef mingw32_HOST_OS
+ fdIsNonBlocking = fromEnum is_nonblock
+#else
+ fdIsSocket_ = fromEnum is_socket
+#endif
+ },
+ fd_type)
+
+-- -----------------------------------------------------------------------------
+-- Standard file descriptors
+
+stdFD :: CInt -> FD
+stdFD fd = FD { fdFD = fd,
+#ifdef mingw32_HOST_OS
+ fdIsSocket_ = 0
+#else
+ fdIsNonBlocking = 0
+ -- We don't set non-blocking mode on standard handles, because it may
+ -- confuse other applications attached to the same TTY/pipe
+ -- see Note [nonblock]
+#endif
+ }
+
+stdin, stdout, stderr :: FD
+stdin = stdFD 0
+stdout = stdFD 1
+stderr = stdFD 2
+
+-- -----------------------------------------------------------------------------
+-- Operations on file descriptors
+
+close :: FD -> IO ()
+close fd =
+#ifndef mingw32_HOST_OS
+ (flip finally) (release fd) $ do
+#endif
+ throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
+#ifdef mingw32_HOST_OS
+ if fdIsSocket fd then
+ c_closesocket (fdFD fd)
+ else
+#endif
+ c_close (fdFD fd)
+
+release :: FD -> IO ()
+release fd = do
+#ifndef mingw32_HOST_OS
+ unlockFile (fdFD fd)
+#endif
+ let _ = fd -- warning suppression
+ return ()
+
+#ifdef mingw32_HOST_OS
+foreign import stdcall unsafe "HsBase.h closesocket"
+ c_closesocket :: CInt -> IO CInt
+#endif
+
+isSeekable :: FD -> IO Bool
+isSeekable fd = do
+ t <- devType fd
+ return (t == RegularFile || t == RawDevice)
+
+seek :: FD -> SeekMode -> Integer -> IO ()
+seek fd mode off = do
+ throwErrnoIfMinus1Retry "seek" $
+ c_lseek (fdFD fd) (fromIntegral off) seektype
+ return ()
+ where
+ seektype :: CInt
+ seektype = case mode of
+ AbsoluteSeek -> sEEK_SET
+ RelativeSeek -> sEEK_CUR
+ SeekFromEnd -> sEEK_END
+
+tell :: FD -> IO Integer
+tell fd =
+ fromIntegral `fmap`
+ (throwErrnoIfMinus1Retry "hGetPosn" $
+ c_lseek (fdFD fd) 0 sEEK_CUR)
+
+getSize :: FD -> IO Integer
+getSize fd = fdFileSize (fdFD fd)
+
+setSize :: FD -> Integer -> IO ()
+setSize fd size = do
+ throwErrnoIf (/=0) "GHC.IO.FD.setSize" $
+ c_ftruncate (fdFD fd) (fromIntegral size)
+ return ()
+
+devType :: FD -> IO IODeviceType
+devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
+
+dup :: FD -> IO FD
+dup fd = do
+ newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)
+ return fd{ fdFD = newfd }
+
+dup2 :: FD -> FD -> IO FD
+dup2 fd fdto = do
+ -- Windows' dup2 does not return the new descriptor, unlike Unix
+ throwErrnoIfMinus1 "GHC.IO.FD.dup2" $
+ c_dup2 (fdFD fd) (fdFD fdto)
+ return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
+
+setNonBlockingMode :: FD -> IO ()
+setNonBlockingMode fd = setNonBlockingFD (fdFD fd)
+
+ready :: FD -> Bool -> Int -> IO Bool
+ready fd write msecs = do
+ r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
+ fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
+ (fromIntegral msecs)
+#if defined(mingw32_HOST_OS)
+ (fromIntegral $ fromEnum $ fdIsSocket fd)
+#else
+ 0
+#endif
+ return (toEnum (fromIntegral r))
+
+foreign import ccall safe "fdReady"
+ fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+
+-- ---------------------------------------------------------------------------
+-- Terminal-related stuff
+
+isTerminal :: FD -> IO Bool
+isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
+
+setEcho :: FD -> Bool -> IO ()
+setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
+
+getEcho :: FD -> IO Bool
+getEcho fd = System.Posix.Internals.getEcho (fdFD fd)
+
+setRaw :: FD -> Bool -> IO ()
+setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
+
+-- -----------------------------------------------------------------------------
+-- Reading and Writing
+
+fdRead :: FD -> Ptr Word8 -> Int -> IO Int
+fdRead fd ptr bytes = do
+ r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
+ return (fromIntegral r)
+
+fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
+fdReadNonBlocking fd ptr bytes = do
+ r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr
+ 0 (fromIntegral bytes)
+ case r of
+ (-1) -> return (Nothing)
+ n -> return (Just (fromIntegral n))
+
+
+fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
+fdWrite fd ptr bytes = do
+ res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes)
+ let res' = fromIntegral res
+ if res' < bytes
+ then fdWrite fd (ptr `plusPtr` bytes) (bytes - res')
+ else return ()
+
+-- XXX ToDo: this isn't non-blocking
+fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int
+fdWriteNonBlocking fd ptr bytes = do
+ res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0
+ (fromIntegral bytes)
+ return (fromIntegral res)
+
+-- -----------------------------------------------------------------------------
+-- FD operations
+
+-- Low level routines for reading/writing to (raw)buffers:
+
+#ifndef mingw32_HOST_OS
+
+{-
+NOTE [nonblock]:
+
+Unix has broken semantics when it comes to non-blocking I/O: you can
+set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
+attached to the same underlying file, pipe or TTY; there's no way to
+have private non-blocking behaviour for an FD. See bug #724.
+
+We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
+come from external sources or are exposed externally are left in
+blocking mode. This solution has some problems though. We can't
+completely simulate a non-blocking read without O_NONBLOCK: several
+cases are wrong here. The cases that are wrong:
+
+ * reading/writing to a blocking FD in non-threaded mode.
+ In threaded mode, we just make a safe call to read().
+ In non-threaded mode we call select() before attempting to read,
+ but that leaves a small race window where the data can be read
+ from the file descriptor before we issue our blocking read().
+ * readRawBufferNoBlock for a blocking FD
+
+NOTE [2363]:
+
+In the threaded RTS we could just make safe calls to read()/write()
+for file descriptors in blocking mode without worrying about blocking
+other threads, but the problem with this is that the thread will be
+uninterruptible while it is blocked in the foreign call. See #2363.
+So now we always call fdReady() before reading, and if fdReady
+indicates that there's no data, we call threadWaitRead.
+
+-}
+
+readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtr loc !fd buf off len
+ | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- throwErrnoIfMinus1 loc
+ (unsafe_fdReady (fdFD fd) 0 0 0)
+ if r /= 0
+ then read
+ else do threadWaitRead (fromIntegral (fdFD fd)); read
+ where
+ do_read call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitRead (fromIntegral (fdFD fd)))
+ read = if threaded then safe_read else unsafe_read
+ unsafe_read = do_read (read_off (fdFD fd) buf off len)
+ safe_read = do_read (safe_read_off (fdFD fd) buf off len)
+
+-- return: -1 indicates EOF, >=0 is bytes read
+readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtrNoBlock loc !fd buf off len
+ | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
+ if r /= 0 then safe_read
+ else return 0
+ -- XXX see note [nonblock]
+ where
+ do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
+ case r of
+ (-1) -> return 0
+ 0 -> return (-1)
+ n -> return n
+ unsafe_read = do_read (read_off (fdFD fd) buf off len)
+ safe_read = do_read (safe_read_off (fdFD fd) buf off len)
+
+writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtr loc !fd buf off len
+ | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
+ if r /= 0
+ then write
+ else do threadWaitWrite (fromIntegral (fdFD fd)); write
+ where
+ do_write call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitWrite (fromIntegral (fdFD fd)))
+ write = if threaded then safe_write else unsafe_write
+ unsafe_write = do_write (write_off (fdFD fd) buf off len)
+ safe_write = do_write (safe_write_off (fdFD fd) buf off len)
+
+writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtrNoBlock loc !fd buf off len
+ | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
+ if r /= 0 then write
+ else return 0
+ where
+ do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))
+ case r of
+ (-1) -> return 0
+ n -> return n
+ write = if threaded then safe_write else unsafe_write
+ unsafe_write = do_write (write_off (fdFD fd) buf off len)
+ safe_write = do_write (safe_write_off (fdFD fd) buf off len)
+
+isNonBlocking :: FD -> Bool
+isNonBlocking fd = fdIsNonBlocking fd /= 0
+
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "fdReady"
+ unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+
+#else /* mingw32_HOST_OS.... */
+
+readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtr loc !fd buf off len
+ | threaded = blockingReadRawBufferPtr loc fd buf off len
+ | otherwise = asyncReadRawBufferPtr loc fd buf off len
+
+writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtr loc !fd buf off len
+ | threaded = blockingWriteRawBufferPtr loc fd buf off len
+ | otherwise = asyncWriteRawBufferPtr loc fd buf off len
+
+readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+readRawBufferPtrNoBlock = readRawBufferPtr
+
+writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+writeRawBufferPtrNoBlock = writeRawBufferPtr
+
+-- Async versions of the read/write primitives, for the non-threaded RTS
+
+asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+asyncReadRawBufferPtr loc !fd buf off len = do
+ (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
+ (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+asyncWriteRawBufferPtr loc !fd buf off len = do
+ (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
+ (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+-- Blocking versions of the read/write primitives, for the threaded RTS
+
+blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt
+blockingReadRawBufferPtr loc fd buf off len
+ = throwErrnoIfMinus1Retry loc $
+ if fdIsSocket fd
+ then safe_recv_off (fdFD fd) buf off len
+ else safe_read_off (fdFD fd) buf off len
+
+blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CInt -> IO CInt
+blockingWriteRawBufferPtr loc fd buf off len
+ = throwErrnoIfMinus1Retry loc $
+ if fdIsSocket fd
+ then safe_send_off (fdFD fd) buf off len
+ else safe_write_off (fdFD fd) buf off len
+
+-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
+-- These calls may block, but that's ok.
+
+foreign import ccall safe "__hscore_PrelHandle_recv"
+ safe_recv_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_send"
+ safe_send_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+
+#endif
+
+foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
+
+foreign import ccall safe "__hscore_PrelHandle_read"
+ safe_read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_write"
+ safe_write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt
+
+-- -----------------------------------------------------------------------------
+-- utils
+
+#ifndef mingw32_HOST_OS
+throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
+throwErrnoIfMinus1RetryOnBlock loc f on_block =
+ do
+ res <- f
+ if (res :: CInt) == -1
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfMinus1RetryOnBlock loc f on_block
+ else if err == eWOULDBLOCK || err == eAGAIN
+ then do on_block
+ else throwErrno loc
+ else return res
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Locking/unlocking
+
+#ifndef mingw32_HOST_OS
+foreign import ccall unsafe "lockFile"
+ lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
+
+foreign import ccall unsafe "unlockFile"
+ unlockFile :: CInt -> IO CInt
+#endif
+
+#if defined(DEBUG_DUMP)
+puts :: String -> IO ()
+puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)
+ return ()
+#endif
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -XRecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Handle
+-- Copyright : (c) The University of Glasgow, 1994-2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : non-portable
+--
+-- External API for GHC's Handle implementation
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Handle (
+ Handle,
+ BufferMode(..),
+
+ mkFileHandle, mkDuplexHandle,
+
+ hFileSize, hSetFileSize, hIsEOF, hLookAhead,
+ hSetBuffering, hSetBinaryMode, hSetEncoding,
+ hFlush, hDuplicate, hDuplicateTo,
+
+ hClose, hClose_help,
+
+ HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
+ SeekMode(..), hSeek, hTell,
+
+ hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
+ hSetEcho, hGetEcho, hIsTerminalDevice,
+
+ hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline,
+ noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
+
+ hShow,
+
+ hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
+
+ hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking
+ ) where
+
+import GHC.IO
+import GHC.IO.Exception
+import GHC.IO.Encoding
+import GHC.IO.Buffer
+import GHC.IO.BufferedIO ( BufferedIO )
+import GHC.IO.Device as IODevice
+import GHC.IO.Handle.Types
+import GHC.IO.Handle.Internals
+import GHC.IO.Handle.Text
+import System.IO.Error
+
+import GHC.Base
+import GHC.Exception
+import GHC.MVar
+import GHC.IORef
+import GHC.Show
+import GHC.Num
+import GHC.Real
+import Data.Maybe
+import Data.Typeable
+import Control.Monad
+
+-- ---------------------------------------------------------------------------
+-- Closing a handle
+
+-- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
+-- computation finishes, if @hdl@ is writable its buffer is flushed as
+-- for 'hFlush'.
+-- Performing 'hClose' on a handle that has already been closed has no effect;
+-- doing so is not an error. All other operations on a closed handle will fail.
+-- If 'hClose' fails for any reason, any further operations (apart from
+-- 'hClose') on the handle will still fail as if @hdl@ had been successfully
+-- closed.
+
+hClose :: Handle -> IO ()
+hClose h@(FileHandle _ m) = do
+ mb_exc <- hClose' h m
+ case mb_exc of
+ Nothing -> return ()
+ Just e -> hClose_rethrow e h
+hClose h@(DuplexHandle _ r w) = do
+ mb_exc1 <- hClose' h w
+ mb_exc2 <- hClose' h r
+ case (do mb_exc1; mb_exc2) of
+ Nothing -> return ()
+ Just e -> hClose_rethrow e h
+
+hClose_rethrow :: SomeException -> Handle -> IO ()
+hClose_rethrow e h =
+ case fromException e of
+ Just ioe -> ioError (augmentIOError ioe "hClose" h)
+ Nothing -> throwIO e
+
+hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
+hClose' h m = withHandle' "hClose" h m $ hClose_help
+
+-----------------------------------------------------------------------------
+-- Detecting and changing the size of a file
+
+-- | For a handle @hdl@ which attached to a physical file,
+-- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
+
+hFileSize :: Handle -> IO Integer
+hFileSize handle =
+ withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ _ -> do flushWriteBuffer handle_
+ r <- IODevice.getSize dev
+ if r /= -1
+ then return r
+ else ioException (IOError Nothing InappropriateType "hFileSize"
+ "not a regular file" Nothing Nothing)
+
+
+-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
+
+hSetFileSize :: Handle -> Integer -> IO ()
+hSetFileSize handle size =
+ withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ _ -> do flushWriteBuffer handle_
+ IODevice.setSize dev size
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- Detecting the End of Input
+
+-- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
+-- 'True' if no further input can be taken from @hdl@ or for a
+-- physical file, if the current I\/O position is equal to the length of
+-- the file. Otherwise, it returns 'False'.
+--
+-- NOTE: 'hIsEOF' may block, because it is the same as calling
+-- 'hLookAhead' and checking for an EOF exception.
+
+hIsEOF :: Handle -> IO Bool
+hIsEOF handle =
+ catch
+ (do hLookAhead handle; return False)
+ (\e -> if isEOFError e then return True else ioError e)
+
+-- ---------------------------------------------------------------------------
+-- Looking ahead
+
+-- | Computation 'hLookAhead' returns the next character from the handle
+-- without removing it from the input buffer, blocking until a character
+-- is available.
+--
+-- This operation may fail with:
+--
+-- * 'isEOFError' if the end of file has been reached.
+
+hLookAhead :: Handle -> IO Char
+hLookAhead handle =
+ wantReadableHandle_ "hLookAhead" handle hLookAhead_
+
+-- ---------------------------------------------------------------------------
+-- Buffering Operations
+
+-- Three kinds of buffering are supported: line-buffering,
+-- block-buffering or no-buffering. See GHC.IO.Handle for definition and
+-- further explanation of what the type represent.
+
+-- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
+-- handle @hdl@ on subsequent reads and writes.
+--
+-- If the buffer mode is changed from 'BlockBuffering' or
+-- 'LineBuffering' to 'NoBuffering', then
+--
+-- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
+--
+-- * if @hdl@ is not writable, the contents of the buffer is discarded.
+--
+-- This operation may fail with:
+--
+-- * 'isPermissionError' if the handle has already been used for reading
+-- or writing and the implementation does not allow the buffering mode
+-- to be changed.
+
+hSetBuffering :: Handle -> BufferMode -> IO ()
+hSetBuffering handle mode =
+ withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do
+ case haType of
+ ClosedHandle -> ioe_closedHandle
+ _ -> do
+ if mode == haBufferMode then return handle_ else do
+
+ {- Note:
+ - we flush the old buffer regardless of whether
+ the new buffer could fit the contents of the old buffer
+ or not.
+ - allow a handle's buffering to change even if IO has
+ occurred (ANSI C spec. does not allow this, nor did
+ the previous implementation of IO.hSetBuffering).
+ - a non-standard extension is to allow the buffering
+ of semi-closed handles to change [sof 6/98]
+ -}
+ flushCharBuffer handle_
+
+ let state = initBufferState haType
+ reading = not (isWritableHandleType haType)
+
+ new_buf <-
+ case mode of
+ -- See [note Buffer Sizing], GHC.IO.Handle.Types
+ NoBuffering | reading -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
+ | otherwise -> newCharBuffer 1 state
+ LineBuffering -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
+ BlockBuffering Nothing -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
+ BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
+ | otherwise -> newCharBuffer n state
+
+ writeIORef haCharBuffer new_buf
+
+ -- for input terminals we need to put the terminal into
+ -- cooked or raw mode depending on the type of buffering.
+ is_tty <- IODevice.isTerminal haDevice
+ when (is_tty && isReadableHandleType haType) $
+ case mode of
+#ifndef mingw32_HOST_OS
+ -- 'raw' mode under win32 is a bit too specialised (and troublesome
+ -- for most common uses), so simply disable its use here.
+ NoBuffering -> IODevice.setRaw haDevice True
+#else
+ NoBuffering -> return ()
+#endif
+ _ -> IODevice.setRaw haDevice False
+
+ -- throw away spare buffers, they might be the wrong size
+ writeIORef haBuffers BufferListNil
+
+ return Handle__{ haBufferMode = mode,.. }
+
+-- -----------------------------------------------------------------------------
+-- hSetEncoding
+
+-- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding
+-- for the handle @hdl@ to @encoding@. Encodings are available from the
+-- module "GHC.IO.Encoding". The default encoding when a 'Handle' is
+-- created is 'localeEncoding', namely the default encoding for the current
+-- locale.
+--
+-- To create a 'Handle' with no encoding at all, use 'openBinaryFile'. To
+-- stop further encoding or decoding on an existing 'Handle', use
+-- 'hSetBinaryMode'.
+--
+hSetEncoding :: Handle -> TextEncoding -> IO ()
+hSetEncoding hdl encoding = do
+ withHandle "hSetEncoding" hdl $ \h_@Handle__{..} -> do
+ flushCharBuffer h_
+ (mb_encoder,mb_decoder) <- getEncoding (Just encoding) haType
+ return (Handle__{ haDecoder = mb_decoder, haEncoder = mb_encoder, .. },
+ ())
+
+-- -----------------------------------------------------------------------------
+-- hFlush
+
+-- | The action 'hFlush' @hdl@ causes any items buffered for output
+-- in handle @hdl@ to be sent immediately to the operating system.
+--
+-- This operation may fail with:
+--
+-- * 'isFullError' if the device is full;
+--
+-- * 'isPermissionError' if a system resource limit would be exceeded.
+-- It is unspecified whether the characters in the buffer are discarded
+-- or retained under these circumstances.
+
+hFlush :: Handle -> IO ()
+hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
+
+-- -----------------------------------------------------------------------------
+-- Repositioning Handles
+
+data HandlePosn = HandlePosn Handle HandlePosition
+
+instance Eq HandlePosn where
+ (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
+
+instance Show HandlePosn where
+ showsPrec p (HandlePosn h pos) =
+ showsPrec p h . showString " at position " . shows pos
+
+ -- HandlePosition is the Haskell equivalent of POSIX' off_t.
+ -- We represent it as an Integer on the Haskell side, but
+ -- cheat slightly in that hGetPosn calls upon a C helper
+ -- that reports the position back via (merely) an Int.
+type HandlePosition = Integer
+
+-- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
+-- @hdl@ as a value of the abstract type 'HandlePosn'.
+
+hGetPosn :: Handle -> IO HandlePosn
+hGetPosn handle = do
+ posn <- hTell handle
+ return (HandlePosn handle posn)
+
+-- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
+-- then computation 'hSetPosn' @p@ sets the position of @hdl@
+-- to the position it held at the time of the call to 'hGetPosn'.
+--
+-- This operation may fail with:
+--
+-- * 'isPermissionError' if a system resource limit would be exceeded.
+
+hSetPosn :: HandlePosn -> IO ()
+hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
+
+-- ---------------------------------------------------------------------------
+-- hSeek
+
+{- Note:
+ - when seeking using `SeekFromEnd', positive offsets (>=0) means
+ seeking at or past EOF.
+
+ - we possibly deviate from the report on the issue of seeking within
+ the buffer and whether to flush it or not. The report isn't exactly
+ clear here.
+-}
+
+-- | Computation 'hSeek' @hdl mode i@ sets the position of handle
+-- @hdl@ depending on @mode@.
+-- The offset @i@ is given in terms of 8-bit bytes.
+--
+-- If @hdl@ is block- or line-buffered, then seeking to a position which is not
+-- in the current buffer will first cause any items in the output buffer to be
+-- written to the device, and then cause the input buffer to be discarded.
+-- Some handles may not be seekable (see 'hIsSeekable'), or only support a
+-- subset of the possible positioning operations (for instance, it may only
+-- be possible to seek to the end of a tape, or to a positive offset from
+-- the beginning or current position).
+-- It is not possible to set a negative I\/O position, or for
+-- a physical file, an I\/O position beyond the current end-of-file.
+--
+-- This operation may fail with:
+--
+-- * 'isPermissionError' if a system resource limit would be exceeded.
+
+hSeek :: Handle -> SeekMode -> Integer -> IO ()
+hSeek handle mode offset =
+ wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do
+ debugIO ("hSeek " ++ show (mode,offset))
+ buf <- readIORef haCharBuffer
+
+ if isWriteBuffer buf
+ then do flushWriteBuffer handle_
+ IODevice.seek haDevice mode offset
+ else do
+
+ let r = bufL buf; w = bufR buf
+ if mode == RelativeSeek && isNothing haDecoder &&
+ offset >= 0 && offset < fromIntegral (w - r)
+ then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset }
+ else do
+
+ flushCharReadBuffer handle_
+ flushByteReadBuffer handle_
+ IODevice.seek haDevice mode offset
+
+
+hTell :: Handle -> IO Integer
+hTell handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do
+
+ posn <- IODevice.tell haDevice
+
+ cbuf <- readIORef haCharBuffer
+ bbuf <- readIORef haByteBuffer
+
+ let real_posn
+ | isWriteBuffer cbuf = posn + fromIntegral (bufR cbuf)
+ | otherwise = posn - fromIntegral (bufR cbuf - bufL cbuf)
+ - fromIntegral (bufR bbuf - bufL bbuf)
+
+ debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn))
+ debugIO (" cbuf: " ++ summaryBuffer cbuf ++
+ " bbuf: " ++ summaryBuffer bbuf)
+
+ return real_posn
+
+-- -----------------------------------------------------------------------------
+-- Handle Properties
+
+-- A number of operations return information about the properties of a
+-- handle. Each of these operations returns `True' if the handle has
+-- the specified property, and `False' otherwise.
+
+hIsOpen :: Handle -> IO Bool
+hIsOpen handle =
+ withHandle_ "hIsOpen" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return False
+ SemiClosedHandle -> return False
+ _ -> return True
+
+hIsClosed :: Handle -> IO Bool
+hIsClosed handle =
+ withHandle_ "hIsClosed" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return True
+ _ -> return False
+
+{- not defined, nor exported, but mentioned
+ here for documentation purposes:
+
+ hSemiClosed :: Handle -> IO Bool
+ hSemiClosed h = do
+ ho <- hIsOpen h
+ hc <- hIsClosed h
+ return (not (ho || hc))
+-}
+
+hIsReadable :: Handle -> IO Bool
+hIsReadable (DuplexHandle _ _ _) = return True
+hIsReadable handle =
+ withHandle_ "hIsReadable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isReadableHandleType htype)
+
+hIsWritable :: Handle -> IO Bool
+hIsWritable (DuplexHandle _ _ _) = return True
+hIsWritable handle =
+ withHandle_ "hIsWritable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isWritableHandleType htype)
+
+-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
+-- for @hdl@.
+
+hGetBuffering :: Handle -> IO BufferMode
+hGetBuffering handle =
+ withHandle_ "hGetBuffering" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ ->
+ -- We're being non-standard here, and allow the buffering
+ -- of a semi-closed handle to be queried. -- sof 6/98
+ return (haBufferMode handle_) -- could be stricter..
+
+hIsSeekable :: Handle -> IO Bool
+hIsSeekable handle =
+ withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do
+ case haType of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> return False
+ _ -> IODevice.isSeekable haDevice
+
+-- -----------------------------------------------------------------------------
+-- Changing echo status (Non-standard GHC extensions)
+
+-- | Set the echoing status of a handle connected to a terminal.
+
+hSetEcho :: Handle -> Bool -> IO ()
+hSetEcho handle on = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return ()
+ else
+ withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do
+ case haType of
+ ClosedHandle -> ioe_closedHandle
+ _ -> IODevice.setEcho haDevice on
+
+-- | Get the echoing status of a handle connected to a terminal.
+
+hGetEcho :: Handle -> IO Bool
+hGetEcho handle = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return False
+ else
+ withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do
+ case haType of
+ ClosedHandle -> ioe_closedHandle
+ _ -> IODevice.getEcho haDevice
+
+-- | Is the handle connected to a terminal?
+
+hIsTerminalDevice :: Handle -> IO Bool
+hIsTerminalDevice handle = do
+ withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do
+ case haType of
+ ClosedHandle -> ioe_closedHandle
+ _ -> IODevice.isTerminal haDevice
+
+-- -----------------------------------------------------------------------------
+-- hSetBinaryMode
+
+-- | Select binary mode ('True') or text mode ('False') on a open handle.
+-- (See also 'openBinaryFile'.)
+--
+-- This has the same effect as calling 'hSetEncoding' with 'latin1', together
+-- with 'hSetNewlineMode' with 'noNewlineTranslation'.
+--
+hSetBinaryMode :: Handle -> Bool -> IO ()
+hSetBinaryMode handle bin =
+ withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} ->
+ do
+ flushBuffer h_
+ let mb_te | bin = Nothing
+ | otherwise = Just localeEncoding
+
+ -- should match the default newline mode, whatever that is
+ let nl | bin = noNewlineTranslation
+ | otherwise = nativeNewlineMode
+
+ (mb_encoder, mb_decoder) <- getEncoding mb_te haType
+ return Handle__{ haEncoder = mb_encoder,
+ haDecoder = mb_decoder,
+ haInputNL = inputNL nl,
+ haOutputNL = outputNL nl, .. }
+
+-- -----------------------------------------------------------------------------
+-- hSetNewlineMode
+
+-- | Set the 'NewlineMode' on the specified 'Handle'. All buffered
+-- data is flushed first.
+hSetNewlineMode :: Handle -> NewlineMode -> IO ()
+hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =
+ withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} ->
+ do
+ flushBuffer h_
+ return h_{ haInputNL=i, haOutputNL=o }
+
+-- -----------------------------------------------------------------------------
+-- Duplicating a Handle
+
+-- | Returns a duplicate of the original handle, with its own buffer.
+-- The two Handles will share a file pointer, however. The original
+-- handle's buffer is flushed, including discarding any input data,
+-- before the handle is duplicated.
+
+hDuplicate :: Handle -> IO Handle
+hDuplicate h@(FileHandle path m) = do
+ withHandle_' "hDuplicate" h m $ \h_ ->
+ dupHandle path h Nothing h_ (Just handleFinalizer)
+hDuplicate h@(DuplexHandle path r w) = do
+ write_side@(FileHandle _ write_m) <-
+ withHandle_' "hDuplicate" h w $ \h_ ->
+ dupHandle path h Nothing h_ (Just handleFinalizer)
+ read_side@(FileHandle _ read_m) <-
+ withHandle_' "hDuplicate" h r $ \h_ ->
+ dupHandle path h (Just write_m) h_ Nothing
+ return (DuplexHandle path read_m write_m)
+
+dupHandle :: FilePath
+ -> Handle
+ -> Maybe (MVar Handle__)
+ -> Handle__
+ -> Maybe HandleFinalizer
+ -> IO Handle
+dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do
+ -- flush the buffer first, so we don't have to copy its contents
+ flushBuffer h_
+ case other_side of
+ Nothing -> do
+ new_dev <- IODevice.dup haDevice
+ dupHandle_ new_dev filepath other_side h_ mb_finalizer
+ Just r ->
+ withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do
+ dupHandle_ dev filepath other_side h_ mb_finalizer
+
+dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
+ -> FilePath
+ -> Maybe (MVar Handle__)
+ -> Handle__
+ -> Maybe HandleFinalizer
+ -> IO Handle
+dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
+ -- XXX wrong!
+ let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing
+ mkHandle new_dev filepath haType True{-buffered-} mb_codec
+ NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
+ mb_finalizer other_side
+
+-- -----------------------------------------------------------------------------
+-- Replacing a Handle
+
+{- |
+Makes the second handle a duplicate of the first handle. The second
+handle will be closed first, if it is not already.
+
+This can be used to retarget the standard Handles, for example:
+
+> do h <- openFile "mystdout" WriteMode
+> hDuplicateTo h stdout
+-}
+
+hDuplicateTo :: Handle -> Handle -> IO ()
+hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
+ _ <- hClose_help h2_
+ withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
+ dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
+hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
+ withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
+ _ <- hClose_help w2_
+ withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
+ dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
+ withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
+ _ <- hClose_help r2_
+ withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
+ dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
+hDuplicateTo h1 _ =
+ ioe_dupHandlesNotCompatible h1
+
+
+ioe_dupHandlesNotCompatible :: Handle -> IO a
+ioe_dupHandlesNotCompatible h =
+ ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
+ "handles are incompatible" Nothing Nothing)
+
+dupHandleTo :: FilePath
+ -> Handle
+ -> Maybe (MVar Handle__)
+ -> Handle__
+ -> Handle__
+ -> Maybe HandleFinalizer
+ -> IO Handle__
+dupHandleTo filepath h other_side
+ hto_@Handle__{haDevice=devTo,..}
+ h_@Handle__{haDevice=dev} mb_finalizer = do
+ flushBuffer h_
+ case cast devTo of
+ Nothing -> ioe_dupHandlesNotCompatible h
+ Just dev' -> do
+ IODevice.dup2 dev dev'
+ FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
+ takeMVar m
+
+-- ---------------------------------------------------------------------------
+-- showing Handles.
+--
+-- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
+-- than the (pure) instance of 'Show' for 'Handle'.
+
+hShow :: Handle -> IO String
+hShow h@(FileHandle path _) = showHandle' path False h
+hShow h@(DuplexHandle path _ _) = showHandle' path True h
+
+showHandle' :: String -> Bool -> Handle -> IO String
+showHandle' filepath is_duplex h =
+ withHandle_ "showHandle" h $ \hdl_ ->
+ let
+ showType | is_duplex = showString "duplex (read-write)"
+ | otherwise = shows (haType hdl_)
+ in
+ return
+ (( showChar '{' .
+ showHdl (haType hdl_)
+ (showString "loc=" . showString filepath . showChar ',' .
+ showString "type=" . showType . showChar ',' .
+ showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
+ ) "")
+ where
+
+ showHdl :: HandleType -> ShowS -> ShowS
+ showHdl ht cont =
+ case ht of
+ ClosedHandle -> shows ht . showString "}"
+ _ -> cont
+
+ showBufMode :: Buffer e -> BufferMode -> ShowS
+ showBufMode buf bmo =
+ case bmo of
+ NoBuffering -> showString "none"
+ LineBuffering -> showString "line"
+ BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
+ BlockBuffering Nothing -> showString "block " . showParen True (shows def)
+ where
+ def :: Int
+ def = bufSize buf
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+module GHC.IO.Handle where
+
+import GHC.IO
+import GHC.IO.Handle.Types
+
+hFlush :: Handle -> IO ()
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Handle.FD
+-- Copyright : (c) The University of Glasgow, 1994-2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- Handle operations implemented by file descriptors (FDs)
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Handle.FD (
+ stdin, stdout, stderr,
+ openFile, openBinaryFile,
+ mkHandleFromFD, fdToHandle, fdToHandle',
+ isEOF
+ ) where
+
+import GHC.Base
+import GHC.Num
+import GHC.Real
+import GHC.Show
+import Data.Maybe
+import Control.Monad
+import Foreign.C.Types
+import GHC.MVar
+import GHC.IO
+import GHC.IO.Encoding
+import GHC.IO.Exception
+import GHC.IO.Device as IODevice
+import GHC.IO.Exception
+import GHC.IO.IOMode
+import GHC.IO.Handle
+import GHC.IO.Handle.Types
+import GHC.IO.Handle.Internals
+import GHC.IO.FD (FD(..))
+import qualified GHC.IO.FD as FD
+import qualified System.Posix.Internals as Posix
+
+-- ---------------------------------------------------------------------------
+-- Standard Handles
+
+-- Three handles are allocated during program initialisation. The first
+-- two manage input or output from the Haskell program's standard input
+-- or output channel respectively. The third manages output to the
+-- standard error channel. These handles are initially open.
+
+-- | A handle managing input from the Haskell program's standard input channel.
+stdin :: Handle
+stdin = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ mkHandle FD.stdin "<stdin>" ReadHandle True (Just localeEncoding)
+ nativeNewlineMode{-translate newlines-}
+ (Just stdHandleFinalizer) Nothing
+
+-- | A handle managing output to the Haskell program's standard output channel.
+stdout :: Handle
+stdout = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ mkHandle FD.stdout "<stdout>" WriteHandle True (Just localeEncoding)
+ nativeNewlineMode{-translate newlines-}
+ (Just stdHandleFinalizer) Nothing
+
+-- | A handle managing output to the Haskell program's standard error channel.
+stderr :: Handle
+stderr = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-}
+ (Just localeEncoding)
+ nativeNewlineMode{-translate newlines-}
+ (Just stdHandleFinalizer) Nothing
+
+stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+stdHandleFinalizer fp m = do
+ h_ <- takeMVar m
+ flushWriteBuffer h_
+ putMVar m (ioe_finalizedHandle fp)
+
+-- ---------------------------------------------------------------------------
+-- isEOF
+
+-- | The computation 'isEOF' is identical to 'hIsEOF',
+-- except that it works only on 'stdin'.
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+-- ---------------------------------------------------------------------------
+-- Opening and Closing Files
+
+addFilePathToIOError :: String -> FilePath -> IOException -> IOException
+addFilePathToIOError fun fp ioe
+ = ioe{ ioe_location = fun, ioe_filename = Just fp }
+
+-- | Computation 'openFile' @file mode@ allocates and returns a new, open
+-- handle to manage the file @file@. It manages input if @mode@
+-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
+-- and both input and output if mode is 'ReadWriteMode'.
+--
+-- If the file does not exist and it is opened for output, it should be
+-- created as a new file. If @mode@ is 'WriteMode' and the file
+-- already exists, then it should be truncated to zero length.
+-- Some operating systems delete empty files, so there is no guarantee
+-- that the file will exist following an 'openFile' with @mode@
+-- 'WriteMode' unless it is subsequently written to successfully.
+-- The handle is positioned at the end of the file if @mode@ is
+-- 'AppendMode', and otherwise at the beginning (in which case its
+-- internal position is 0).
+-- The initial buffer mode is implementation-dependent.
+--
+-- This operation may fail with:
+--
+-- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
+--
+-- * 'isDoesNotExistError' if the file does not exist; or
+--
+-- * 'isPermissionError' if the user does not have permission to open the file.
+--
+-- Note: if you will be working with files containing binary data, you'll want to
+-- be using 'openBinaryFile'.
+openFile :: FilePath -> IOMode -> IO Handle
+openFile fp im =
+ catchException
+ (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
+ (\e -> ioError (addFilePathToIOError "openFile" fp e))
+
+-- | Like 'openFile', but open the file in binary mode.
+-- On Windows, reading a file in text mode (which is the default)
+-- will translate CRLF to LF, and writing will translate LF to CRLF.
+-- This is usually what you want with text files. With binary files
+-- this is undesirable; also, as usual under Microsoft operating systems,
+-- text mode treats control-Z as EOF. Binary mode turns off all special
+-- treatment of end-of-line and end-of-file characters.
+-- (See also 'hSetBinaryMode'.)
+
+openBinaryFile :: FilePath -> IOMode -> IO Handle
+openBinaryFile fp m =
+ catchException
+ (openFile' fp m True)
+ (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
+
+openFile' :: String -> IOMode -> Bool -> IO Handle
+openFile' filepath iomode binary = do
+ -- first open the file to get an FD
+ (fd, fd_type) <- FD.openFile filepath iomode
+
+ let mb_codec = if binary then Nothing else Just localeEncoding
+
+ -- then use it to make a Handle
+ mkHandleFromFD fd fd_type filepath iomode True{-non-blocking-} mb_codec
+ `onException` IODevice.close fd
+ -- NB. don't forget to close the FD if mkHandleFromFD fails, otherwise
+ -- this FD leaks.
+ -- ASSERT: if we just created the file, then fdToHandle' won't fail
+ -- (so we don't need to worry about removing the newly created file
+ -- in the event of an error).
+
+
+-- ---------------------------------------------------------------------------
+-- Converting file descriptors to Handles
+
+mkHandleFromFD
+ :: FD
+ -> IODeviceType
+ -> FilePath -- a string describing this file descriptor (e.g. the filename)
+ -> IOMode
+ -> Bool -- non_blocking (*sets* non-blocking mode on the FD)
+ -> Maybe TextEncoding
+ -> IO Handle
+
+mkHandleFromFD fd fd_type filepath iomode set_non_blocking mb_codec
+ = do
+#ifndef mingw32_HOST_OS
+ when set_non_blocking $ FD.setNonBlockingMode fd
+ -- turn on non-blocking mode
+#else
+ let _ = set_non_blocking -- warning suppression
+#endif
+
+ let nl | isJust mb_codec = nativeNewlineMode
+ | otherwise = noNewlineTranslation
+
+ case fd_type of
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing Nothing)
+
+ Stream
+ -- only *Streams* can be DuplexHandles. Other read/write
+ -- Handles must share a buffer.
+ | ReadWriteMode <- iomode ->
+ mkDuplexHandle fd filepath mb_codec nl
+
+
+ _other ->
+ mkFileHandle fd filepath iomode mb_codec nl
+
+-- | Old API kept to avoid breaking clients
+fdToHandle' :: CInt
+ -> Maybe IODeviceType
+ -> Bool -- is_socket on Win, non-blocking on Unix
+ -> FilePath
+ -> IOMode
+ -> Bool -- binary
+ -> IO Handle
+fdToHandle' fdint mb_type is_socket filepath iomode binary = do
+ let mb_stat = case mb_type of
+ Nothing -> Nothing
+ -- mkFD will do the stat:
+ Just RegularFile -> Nothing
+ -- no stat required for streams etc.:
+ Just other -> Just (other,0,0)
+ (fd,fd_type) <- FD.mkFD (fromIntegral fdint) iomode mb_stat
+ is_socket
+ is_socket
+ mkHandleFromFD fd fd_type filepath iomode is_socket
+ (if binary then Nothing else Just localeEncoding)
+
+
+-- | Turn an existing file descriptor into a Handle. This is used by
+-- various external libraries to make Handles.
+--
+-- Makes a binary Handle. This is for historical reasons; it should
+-- probably be a text Handle with the default encoding and newline
+-- translation instead.
+fdToHandle :: Posix.FD -> IO Handle
+fdToHandle fdint = do
+ iomode <- Posix.fdGetMode (fromIntegral fdint)
+ (fd,fd_type) <- FD.mkFD (fromIntegral fdint) iomode Nothing
+ False{-is_socket-}
+ -- NB. the is_socket flag is False, meaning that:
+ -- on Windows we're guessing this is not a socket (XXX)
+ False{-is_nonblock-}
+ -- file descriptors that we get from external sources are
+ -- not put into non-blocking mode, becuase that would affect
+ -- other users of the file descriptor
+ let fd_str = "<file descriptor: " ++ show fd ++ ">"
+ mkHandleFromFD fd fd_type fd_str iomode False{-non-block-}
+ Nothing -- bin mode
+
+-- ---------------------------------------------------------------------------
+-- Are files opened by default in text or binary mode, if the user doesn't
+-- specify?
+
+dEFAULT_OPEN_IN_BINARY_MODE :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE = False
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+module GHC.IO.Handle.FD where
+
+import GHC.IO.Handle.Types
+
+-- used in GHC.Conc, which is below GHC.IO.Handle.FD
+stdout :: Handle
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -XRecordWildCards #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+#undef DEBUG_DUMP
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Handle.Internals
+-- Copyright : (c) The University of Glasgow, 1994-2001
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- This module defines the basic operations on I\/O \"handles\". All
+-- of the operations defined here are independent of the underlying
+-- device.
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC.IO.Handle.Internals (
+ withHandle, withHandle', withHandle_,
+ withHandle__', withHandle_', withAllHandles__,
+ wantWritableHandle, wantReadableHandle, wantReadableHandle_,
+ wantSeekableHandle,
+
+ mkHandle, mkFileHandle, mkDuplexHandle,
+ getEncoding, initBufferState,
+ dEFAULT_CHAR_BUFFER_SIZE,
+
+ flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer,
+ flushCharBuffer, flushByteReadBuffer,
+
+ readTextDevice, writeTextDevice, readTextDeviceNonBlocking,
+
+ augmentIOError,
+ ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
+ ioe_finalizedHandle, ioe_bufsiz,
+
+ hClose_help, hLookAhead_,
+
+ HandleFinalizer, handleFinalizer,
+
+ debugIO,
+ ) where
+
+import GHC.IO
+import GHC.IO.IOMode
+import GHC.IO.Encoding
+import GHC.IO.Handle.Types
+import GHC.IO.Buffer
+import GHC.IO.BufferedIO (BufferedIO)
+import GHC.IO.Exception
+import GHC.IO.Device (IODevice, SeekMode(..))
+import qualified GHC.IO.Device as IODevice
+import qualified GHC.IO.BufferedIO as Buffered
+
+import GHC.Real
+import GHC.Base
+import GHC.List
+import GHC.Exception
+import GHC.Num ( Num(..) )
+import GHC.Show
+import GHC.IORef
+import GHC.MVar
+import Data.Typeable
+import Control.Monad
+import Data.Maybe
+import Foreign
+import System.IO.Error
+import System.Posix.Internals hiding (FD)
+import qualified System.Posix.Internals as Posix
+
+#ifdef DEBUG_DUMP
+import Foreign.C
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Creating a new handle
+
+type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()
+
+newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle
+newFileHandle filepath mb_finalizer hc = do
+ m <- newMVar hc
+ case mb_finalizer of
+ Just finalizer -> addMVarFinalizer m (finalizer filepath m)
+ Nothing -> return ()
+ return (FileHandle filepath m)
+
+-- ---------------------------------------------------------------------------
+-- Working with Handles
+
+{-
+In the concurrent world, handles are locked during use. This is done
+by wrapping an MVar around the handle which acts as a mutex over
+operations on the handle.
+
+To avoid races, we use the following bracketing operations. The idea
+is to obtain the lock, do some operation and replace the lock again,
+whether the operation succeeded or failed. We also want to handle the
+case where the thread receives an exception while processing the IO
+operation: in these cases we also want to relinquish the lock.
+
+There are three versions of @withHandle@: corresponding to the three
+possible combinations of:
+
+ - the operation may side-effect the handle
+ - the operation may return a result
+
+If the operation generates an error or an exception is raised, the
+original handle is always replaced.
+-}
+
+{-# INLINE withHandle #-}
+withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
+withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
+
+withHandle' :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO (Handle__,a)) -> IO a
+withHandle' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkHandleInvariants h_
+ (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
+ checkHandleInvariants h'
+ putMVar m h'
+ return v
+
+{-# INLINE withHandle_ #-}
+withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
+withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
+withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
+
+withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
+withHandle_' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkHandleInvariants h_
+ v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
+ checkHandleInvariants h_
+ putMVar m h_
+ return v
+
+withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
+withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
+withAllHandles__ fun h@(DuplexHandle _ r w) act = do
+ withHandle__' fun h r act
+ withHandle__' fun h w act
+
+withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
+ -> IO ()
+withHandle__' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkHandleInvariants h_
+ h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
+ checkHandleInvariants h'
+ putMVar m h'
+ return ()
+
+augmentIOError :: IOException -> String -> Handle -> IOException
+augmentIOError ioe@IOError{ ioe_filename = fp } fun h
+ = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }
+ where filepath
+ | Just _ <- fp = fp
+ | otherwise = case h of
+ FileHandle path _ -> Just path
+ DuplexHandle path _ _ -> Just path
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for write operations.
+
+wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantWritableHandle fun h@(FileHandle _ m) act
+ = wantWritableHandle' fun h m act
+wantWritableHandle fun h@(DuplexHandle _ _ m) act
+ = withHandle_' fun h m act
+
+wantWritableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantWritableHandle' fun h m act
+ = withHandle_' fun h m (checkWritableHandle act)
+
+checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
+checkWritableHandle act h_@Handle__{..}
+ = case haType of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ ReadHandle -> ioe_notWritable
+ ReadWriteHandle -> do
+ buf <- readIORef haCharBuffer
+ when (not (isWriteBuffer buf)) $ do
+ flushCharReadBuffer h_
+ flushByteReadBuffer h_
+ buf <- readIORef haCharBuffer
+ writeIORef haCharBuffer buf{ bufState = WriteBuffer }
+ buf <- readIORef haByteBuffer
+ writeIORef haByteBuffer buf{ bufState = WriteBuffer }
+ act h_
+ _other -> act h_
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for read operations.
+
+wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act)
+
+wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantReadableHandle_ fun h@(FileHandle _ m) act
+ = wantReadableHandle' fun h m act
+wantReadableHandle_ fun h@(DuplexHandle _ m _) act
+ = withHandle_' fun h m act
+
+wantReadableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantReadableHandle' fun h m act
+ = withHandle_' fun h m (checkReadableHandle act)
+
+checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
+checkReadableHandle act h_@Handle__{..} =
+ case haType of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notReadable
+ WriteHandle -> ioe_notReadable
+ ReadWriteHandle -> do
+ -- a read/write handle and we want to read from it. We must
+ -- flush all buffered write data first.
+ cbuf <- readIORef haCharBuffer
+ when (isWriteBuffer cbuf) $ do
+ cbuf' <- flushWriteBuffer_ h_ cbuf
+ writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }
+ bbuf <- readIORef haByteBuffer
+ writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }
+ act h_
+ _other -> act h_
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for seek operations.
+
+wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
+ ioException (IOError (Just h) IllegalOperation fun
+ "handle is not seekable" Nothing Nothing)
+wantSeekableHandle fun h@(FileHandle _ m) act =
+ withHandle_' fun h m (checkSeekableHandle act)
+
+checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
+checkSeekableHandle act handle_@Handle__{haDevice=dev} =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notSeekable
+ _ -> do b <- IODevice.isSeekable dev
+ if b then act handle_
+ else ioe_notSeekable
+
+-- -----------------------------------------------------------------------------
+-- Handy IOErrors
+
+ioe_closedHandle, ioe_EOF,
+ ioe_notReadable, ioe_notWritable, ioe_cannotFlushTextRead,
+ ioe_notSeekable, ioe_notSeekable_notBin, ioe_invalidCharacter :: IO a
+
+ioe_closedHandle = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is closed" Nothing Nothing)
+ioe_EOF = ioException
+ (IOError Nothing EOF "" "" Nothing Nothing)
+ioe_notReadable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not open for reading" Nothing Nothing)
+ioe_notWritable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not open for writing" Nothing Nothing)
+ioe_notSeekable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not seekable" Nothing Nothing)
+ioe_notSeekable_notBin = ioException
+ (IOError Nothing IllegalOperation ""
+ "seek operations on text-mode handles are not allowed on this platform"
+ Nothing Nothing)
+ioe_cannotFlushTextRead = ioException
+ (IOError Nothing IllegalOperation ""
+ "cannot flush the read buffer of a text-mode handle"
+ Nothing Nothing)
+ioe_invalidCharacter = ioException
+ (IOError Nothing InvalidArgument ""
+ ("invalid byte sequence for this encoding") Nothing Nothing)
+
+ioe_finalizedHandle :: FilePath -> Handle__
+ioe_finalizedHandle fp = throw
+ (IOError Nothing IllegalOperation ""
+ "handle is finalized" Nothing (Just fp))
+
+ioe_bufsiz :: Int -> IO a
+ioe_bufsiz n = ioException
+ (IOError Nothing InvalidArgument "hSetBuffering"
+ ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
+ -- 9 => should be parens'ified.
+
+-- -----------------------------------------------------------------------------
+-- Handle Finalizers
+
+-- For a duplex handle, we arrange that the read side points to the write side
+-- (and hence keeps it alive if the read side is alive). This is done by
+-- having the haOtherSide field of the read side point to the read side.
+-- The finalizer is then placed on the write side, and the handle only gets
+-- finalized once, when both sides are no longer required.
+
+-- NOTE about finalized handles: It's possible that a handle can be
+-- finalized and then we try to use it later, for example if the
+-- handle is referenced from another finalizer, or from a thread that
+-- has become unreferenced and then resurrected (arguably in the
+-- latter case we shouldn't finalize the Handle...). Anyway,
+-- we try to emit a helpful message which is better than nothing.
+
+handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+handleFinalizer fp m = do
+ handle_ <- takeMVar m
+ case haType handle_ of
+ ClosedHandle -> return ()
+ _ -> do flushWriteBuffer handle_ `catchAny` \_ -> return ()
+ -- ignore errors and async exceptions, and close the
+ -- descriptor anyway...
+ hClose_handle_ handle_
+ return ()
+ putMVar m (ioe_finalizedHandle fp)
+
+-- ---------------------------------------------------------------------------
+-- Allocating buffers
+
+-- using an 8k char buffer instead of 32k improved performance for a
+-- basic "cat" program by ~30% for me. --SDM
+dEFAULT_CHAR_BUFFER_SIZE :: Int
+dEFAULT_CHAR_BUFFER_SIZE = dEFAULT_BUFFER_SIZE `div` 4
+
+getCharBuffer :: IODevice dev => dev -> BufferState
+ -> IO (IORef CharBuffer, BufferMode)
+getCharBuffer dev state = do
+ buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
+ ioref <- newIORef buffer
+ is_tty <- IODevice.isTerminal dev
+
+ let buffer_mode
+ | is_tty = LineBuffering
+ | otherwise = BlockBuffering Nothing
+
+ return (ioref, buffer_mode)
+
+mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
+mkUnBuffer state = do
+ buffer <- case state of -- See [note Buffer Sizing], GHC.IO.Handle.Types
+ ReadBuffer -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
+ WriteBuffer -> newCharBuffer 1 state
+ ref <- newIORef buffer
+ return (ref, NoBuffering)
+
+-- -----------------------------------------------------------------------------
+-- Flushing buffers
+
+-- | syncs the file with the buffer, including moving the
+-- file pointer backwards in the case of a read buffer. This can fail
+-- on a non-seekable read Handle.
+flushBuffer :: Handle__ -> IO ()
+flushBuffer h_@Handle__{..} = do
+ buf <- readIORef haCharBuffer
+ case bufState buf of
+ ReadBuffer -> do
+ flushCharReadBuffer h_
+ flushByteReadBuffer h_
+ WriteBuffer -> do
+ buf' <- flushWriteBuffer_ h_ buf
+ writeIORef haCharBuffer buf'
+
+-- | flushes at least the Char buffer, and the byte buffer for a write
+-- Handle. Works on all Handles.
+flushCharBuffer :: Handle__ -> IO ()
+flushCharBuffer h_@Handle__{..} = do
+ buf <- readIORef haCharBuffer
+ case bufState buf of
+ ReadBuffer -> do
+ flushCharReadBuffer h_
+ WriteBuffer -> do
+ buf' <- flushWriteBuffer_ h_ buf
+ writeIORef haCharBuffer buf'
+
+-- -----------------------------------------------------------------------------
+-- Writing data (flushing write buffers)
+
+-- flushWriteBuffer flushes the buffer iff it contains pending write
+-- data. Flushes both the Char and the byte buffer, leaving both
+-- empty.
+flushWriteBuffer :: Handle__ -> IO ()
+flushWriteBuffer h_@Handle__{..} = do
+ buf <- readIORef haCharBuffer
+ if isWriteBuffer buf
+ then do buf' <- flushWriteBuffer_ h_ buf
+ writeIORef haCharBuffer buf'
+ else return ()
+
+flushWriteBuffer_ :: Handle__ -> CharBuffer -> IO CharBuffer
+flushWriteBuffer_ h_@Handle__{..} cbuf = do
+ bbuf <- readIORef haByteBuffer
+ if not (isEmptyBuffer cbuf) || not (isEmptyBuffer bbuf)
+ then do writeTextDevice h_ cbuf
+ return cbuf{ bufL=0, bufR=0 }
+ else return cbuf
+
+-- -----------------------------------------------------------------------------
+-- Flushing read buffers
+
+-- It is always possible to flush the Char buffer back to the byte buffer.
+flushCharReadBuffer :: Handle__ -> IO ()
+flushCharReadBuffer Handle__{..} = do
+ cbuf <- readIORef haCharBuffer
+ if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do
+
+ -- haLastDecode is the byte buffer just before we did our last batch of
+ -- decoding. We're going to re-decode the bytes up to the current char,
+ -- to find out where we should revert the byte buffer to.
+ bbuf0 <- readIORef haLastDecode
+
+ cbuf0 <- readIORef haCharBuffer
+ writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }
+
+ -- if we haven't used any characters from the char buffer, then just
+ -- re-install the old byte buffer.
+ if bufL cbuf0 == 0
+ then do writeIORef haByteBuffer bbuf0
+ return ()
+ else do
+
+ case haDecoder of
+ Nothing -> do
+ writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }
+ -- no decoder: the number of bytes to decode is the same as the
+ -- number of chars we have used up.
+
+ Just decoder -> do
+ debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
+ " cbuf=" ++ summaryBuffer cbuf0)
+
+ (bbuf1,cbuf1) <- (encode decoder) bbuf0
+ cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
+
+ -- tricky case: if the decoded string starts with e BOM, then it was
+ -- probably ignored last time we decoded these bytes, and we should
+ -- therefore decode another char.
+ (c,_) <- readCharBuf (bufRaw cbuf1) (bufL cbuf1)
+ (bbuf2,_) <- if (c == '\xfeff')
+ then do debugIO "found BOM, decoding another char"
+ (encode decoder) bbuf1
+ cbuf0{ bufL=0, bufR=0, bufSize = 1 }
+ else return (bbuf1,cbuf1)
+
+ debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
+ " cbuf=" ++ summaryBuffer cbuf1)
+
+ writeIORef haByteBuffer bbuf2
+
+
+-- When flushing the byte read buffer, we seek backwards by the number
+-- of characters in the buffer. The file descriptor must therefore be
+-- seekable: attempting to flush the read buffer on an unseekable
+-- handle is not allowed.
+
+flushByteReadBuffer :: Handle__ -> IO ()
+flushByteReadBuffer h_@Handle__{..} = do
+ bbuf <- readIORef haByteBuffer
+
+ if isEmptyBuffer bbuf then return () else do
+
+ seekable <- IODevice.isSeekable haDevice
+ when (not seekable) $ ioe_cannotFlushTextRead
+
+ let seek = negate (bufR bbuf - bufL bbuf)
+
+ debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)
+ IODevice.seek haDevice RelativeSeek (fromIntegral seek)
+
+ writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 }
+
+-- ----------------------------------------------------------------------------
+-- Making Handles
+
+mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
+ -> FilePath
+ -> HandleType
+ -> Bool -- buffered?
+ -> Maybe TextEncoding
+ -> NewlineMode
+ -> (Maybe HandleFinalizer)
+ -> Maybe (MVar Handle__)
+ -> IO Handle
+
+mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
+ let buf_state = initBufferState ha_type
+ bbuf <- Buffered.newBuffer dev buf_state
+ bbufref <- newIORef bbuf
+ last_decode <- newIORef bbuf
+
+ (mb_encoder, mb_decoder) <- getEncoding mb_codec ha_type
+
+ (cbufref,bmode) <-
+ if buffered then getCharBuffer dev buf_state
+ else mkUnBuffer buf_state
+
+ spares <- newIORef BufferListNil
+ newFileHandle filepath finalizer
+ (Handle__ { haDevice = dev,
+ haType = ha_type,
+ haBufferMode = bmode,
+ haByteBuffer = bbufref,
+ haLastDecode = last_decode,
+ haCharBuffer = cbufref,
+ haBuffers = spares,
+ haEncoder = mb_encoder,
+ haDecoder = mb_decoder,
+ haInputNL = inputNL nl,
+ haOutputNL = outputNL nl,
+ haOtherSide = other_side
+ })
+
+-- | makes a new 'Handle'
+mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
+ => dev -- ^ the underlying IO device, which must support
+ -- 'IODevice', 'BufferedIO' and 'Typeable'
+ -> FilePath
+ -- ^ a string describing the 'Handle', e.g. the file
+ -- path for a file. Used in error messages.
+ -> IOMode
+ -- The mode in which the 'Handle' is to be used
+ -> Maybe TextEncoding
+ -- Create the 'Handle' with no text encoding?
+ -> NewlineMode
+ -- Translate newlines?
+ -> IO Handle
+mkFileHandle dev filepath iomode mb_codec tr_newlines = do
+ mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
+ tr_newlines
+ (Just handleFinalizer) Nothing{-other_side-}
+
+-- | like 'mkFileHandle', except that a 'Handle' is created with two
+-- independent buffers, one for reading and one for writing. Used for
+-- full-dupliex streams, such as network sockets.
+mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
+ -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
+mkDuplexHandle dev filepath mb_codec tr_newlines = do
+
+ write_side@(FileHandle _ write_m) <-
+ mkHandle dev filepath WriteHandle True mb_codec
+ tr_newlines
+ (Just handleFinalizer)
+ Nothing -- no othersie
+
+ read_side@(FileHandle _ read_m) <-
+ mkHandle dev filepath ReadHandle True mb_codec
+ tr_newlines
+ Nothing -- no finalizer
+ (Just write_m)
+
+ return (DuplexHandle filepath read_m write_m)
+
+ioModeToHandleType :: IOMode -> HandleType
+ioModeToHandleType ReadMode = ReadHandle
+ioModeToHandleType WriteMode = WriteHandle
+ioModeToHandleType ReadWriteMode = ReadWriteHandle
+ioModeToHandleType AppendMode = AppendHandle
+
+initBufferState :: HandleType -> BufferState
+initBufferState ReadHandle = ReadBuffer
+initBufferState _ = WriteBuffer
+
+getEncoding :: Maybe TextEncoding -> HandleType
+ -> IO (Maybe TextEncoder,
+ Maybe TextDecoder)
+
+getEncoding Nothing ha_type = return (Nothing, Nothing)
+getEncoding (Just te) ha_type = do
+ mb_decoder <- if isReadableHandleType ha_type then do
+ decoder <- mkTextDecoder te
+ return (Just decoder)
+ else
+ return Nothing
+ mb_encoder <- if isWritableHandleType ha_type then do
+ encoder <- mkTextEncoder te
+ return (Just encoder)
+ else
+ return Nothing
+ return (mb_encoder, mb_decoder)
+
+-- ---------------------------------------------------------------------------
+-- closing Handles
+
+-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
+-- or an IO error occurs on a lazy stream. The semi-closed Handle is
+-- then closed immediately. We have to be careful with DuplexHandles
+-- though: we have to leave the closing to the finalizer in that case,
+-- because the write side may still be in use.
+hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
+hClose_help handle_ =
+ case haType handle_ of
+ ClosedHandle -> return (handle_,Nothing)
+ _ -> do flushWriteBuffer handle_ -- interruptible
+ hClose_handle_ handle_
+
+hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
+hClose_handle_ Handle__{..} = do
+
+ -- close the file descriptor, but not when this is the read
+ -- side of a duplex handle.
+ -- If an exception is raised by the close(), we want to continue
+ -- to close the handle and release the lock if it has one, then
+ -- we return the exception to the caller of hClose_help which can
+ -- raise it if necessary.
+ maybe_exception <-
+ case haOtherSide of
+ Nothing -> (do IODevice.close haDevice; return Nothing)
+ `catchException` \e -> return (Just e)
+
+ Just _ -> return Nothing
+
+ -- free the spare buffers
+ writeIORef haBuffers BufferListNil
+ writeIORef haCharBuffer noCharBuffer
+ writeIORef haByteBuffer noByteBuffer
+
+ -- release our encoder/decoder
+ case haDecoder of Nothing -> return (); Just d -> close d
+ case haEncoder of Nothing -> return (); Just d -> close d
+
+ -- we must set the fd to -1, because the finalizer is going
+ -- to run eventually and try to close/unlock it.
+ -- ToDo: necessary? the handle will be marked ClosedHandle
+ -- XXX GHC won't let us use record update here, hence wildcards
+ return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)
+
+{-# NOINLINE noCharBuffer #-}
+noCharBuffer :: CharBuffer
+noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer
+
+{-# NOINLINE noByteBuffer #-}
+noByteBuffer :: Buffer Word8
+noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer
+
+-- ---------------------------------------------------------------------------
+-- Looking ahead
+
+hLookAhead_ :: Handle__ -> IO Char
+hLookAhead_ handle_@Handle__{..} = do
+ buf <- readIORef haCharBuffer
+
+ -- fill up the read buffer if necessary
+ new_buf <- if isEmptyBuffer buf
+ then readTextDevice handle_ buf
+ else return buf
+ writeIORef haCharBuffer new_buf
+
+ peekCharBuf (bufRaw buf) (bufL buf)
+
+-- ---------------------------------------------------------------------------
+-- debugging
+
+debugIO :: String -> IO ()
+#if defined(DEBUG_DUMP)
+debugIO s = do
+ withCStringLen (s++"\n") $ \(p,len) -> c_write 1 p (fromIntegral len)
+ return ()
+#else
+debugIO s = return ()
+#endif
+
+-- ----------------------------------------------------------------------------
+-- Text input/output
+
+-- Write the contents of the supplied Char buffer to the device, return
+-- only when all the data has been written.
+writeTextDevice :: Handle__ -> CharBuffer -> IO ()
+writeTextDevice h_@Handle__{..} cbuf = do
+ --
+ bbuf <- readIORef haByteBuffer
+
+ debugIO ("writeTextDevice: cbuf=" ++ summaryBuffer cbuf ++
+ " bbuf=" ++ summaryBuffer bbuf)
+
+ (cbuf',bbuf') <- case haEncoder of
+ Nothing -> latin1_encode cbuf bbuf
+ Just encoder -> (encode encoder) cbuf bbuf
+
+ debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++
+ " bbuf=" ++ summaryBuffer bbuf')
+
+ Buffered.flushWriteBuffer haDevice bbuf'
+ writeIORef haByteBuffer bbuf{bufL=0,bufR=0}
+ if not (isEmptyBuffer cbuf')
+ then writeTextDevice h_ cbuf'
+ else return ()
+
+-- Read characters into the provided buffer. Return when any
+-- characters are available; raise an exception if the end of
+-- file is reached.
+readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
+readTextDevice h_@Handle__{..} cbuf = do
+ --
+ bbuf0 <- readIORef haByteBuffer
+
+ debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
+ " bbuf=" ++ summaryBuffer bbuf0)
+
+ bbuf1 <- if not (isEmptyBuffer bbuf0)
+ then return bbuf0
+ else do
+ (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
+ if r == 0 then ioe_EOF else do -- raise EOF
+ return bbuf1
+
+ debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
+
+ writeIORef haLastDecode bbuf1
+ (bbuf2,cbuf') <- case haDecoder of
+ Nothing -> latin1_decode bbuf1 cbuf
+ Just decoder -> (encode decoder) bbuf1 cbuf
+
+ debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
+ " bbuf=" ++ summaryBuffer bbuf2)
+
+ writeIORef haByteBuffer bbuf2
+ if bufR cbuf' == bufR cbuf -- no new characters
+ then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char
+ else return cbuf'
+
+-- we have an incomplete byte sequence at the end of the buffer: try to
+-- read more bytes.
+readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
+readTextDevice' h_@Handle__{..} bbuf0 cbuf = do
+ --
+ -- copy the partial sequence to the beginning of the buffer, so we have
+ -- room to read more bytes.
+ bbuf1 <- slideContents bbuf0
+
+ bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
+ if r == 0
+ then ioe_invalidCharacter
+ else return bbuf2
+
+ debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2)
+
+ writeIORef haLastDecode bbuf2
+ (bbuf3,cbuf') <- case haDecoder of
+ Nothing -> latin1_decode bbuf2 cbuf
+ Just decoder -> (encode decoder) bbuf2 cbuf
+
+ debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
+ " bbuf=" ++ summaryBuffer bbuf3)
+
+ writeIORef haByteBuffer bbuf3
+ if bufR cbuf == bufR cbuf'
+ then readTextDevice' h_ bbuf3 cbuf'
+ else return cbuf'
+
+-- Read characters into the provided buffer. Do not block;
+-- return zero characters instead. Raises an exception on end-of-file.
+readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
+readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
+ --
+ bbuf0 <- readIORef haByteBuffer
+ bbuf1 <- if not (isEmptyBuffer bbuf0)
+ then return bbuf0
+ else do
+ (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
+ if r == 0 then ioe_EOF else do -- raise EOF
+ return bbuf1
+
+ (bbuf2,cbuf') <- case haDecoder of
+ Nothing -> latin1_decode bbuf1 cbuf
+ Just decoder -> (encode decoder) bbuf1 cbuf
+
+ writeIORef haByteBuffer bbuf2
+ return cbuf'
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Text
+-- Copyright : (c) The University of Glasgow, 1992-2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- String I\/O functions
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC.IO.Handle.Text (
+ hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
+ commitBuffer', -- hack, see below
+ hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
+ memcpy,
+ ) where
+
+import GHC.IO
+import GHC.IO.FD
+import GHC.IO.Buffer
+import qualified GHC.IO.BufferedIO as Buffered
+import GHC.IO.Exception
+import GHC.IO.Handle.Types
+import GHC.IO.Handle.Internals
+import qualified GHC.IO.Device as IODevice
+import qualified GHC.IO.Device as RawIO
+
+import Foreign
+import Foreign.C
+
+import Data.Typeable
+import System.IO.Error
+import Data.Maybe
+import Control.Monad
+
+import GHC.IORef
+import GHC.Base
+import GHC.Real
+import GHC.Num
+import GHC.Show
+import GHC.List
+
+-- ---------------------------------------------------------------------------
+-- Simple input operations
+
+-- 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.
+
+-- | Computation 'hWaitForInput' @hdl t@
+-- waits until input is available on handle @hdl@.
+-- It returns 'True' as soon as input is available on @hdl@,
+-- or 'False' if no input is available within @t@ milliseconds.
+--
+-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
+--
+-- This operation may fail with:
+--
+-- * 'isEOFError' if the end of file has been reached.
+--
+-- NOTE for GHC users: unless you use the @-threaded@ flag,
+-- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
+-- threads for the duration of the call. It behaves like a
+-- @safe@ foreign call in this respect.
+
+hWaitForInput :: Handle -> Int -> IO Bool
+hWaitForInput h msecs = do
+ wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
+ buf <- readIORef haCharBuffer
+
+ if not (isEmptyBuffer buf)
+ then return True
+ else do
+
+ if msecs < 0
+ then do buf' <- readTextDevice handle_ buf
+ writeIORef haCharBuffer buf'
+ return True
+ else do r <- IODevice.ready haDevice False{-read-} msecs
+ if r then do -- Call hLookAhead' to throw an EOF
+ -- exception if appropriate
+ hLookAhead_ handle_
+ return True
+ else return False
+
+-- ---------------------------------------------------------------------------
+-- hGetChar
+
+-- | Computation 'hGetChar' @hdl@ reads a character from the file or
+-- channel managed by @hdl@, blocking until a character is available.
+--
+-- This operation may fail with:
+--
+-- * 'isEOFError' if the end of file has been reached.
+
+hGetChar :: Handle -> IO Char
+hGetChar handle =
+ wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
+
+ -- buffering mode makes no difference: we just read whatever is available
+ -- from the device (blocking only if there is nothing available), and then
+ -- return the first character.
+ -- See [note Buffered Reading] in GHC.IO.Handle.Types
+ buf0 <- readIORef haCharBuffer
+
+ buf1 <- if isEmptyBuffer buf0
+ then readTextDevice handle_ buf0
+ else return buf0
+
+ (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
+ let buf2 = bufferAdjustL i buf1
+
+ if haInputNL == CRLF && c1 == '\r'
+ then do
+ mbuf3 <- if isEmptyBuffer buf2
+ then maybeFillReadBuffer handle_ buf2
+ else return (Just buf2)
+
+ case mbuf3 of
+ -- EOF, so just return the '\r' we have
+ Nothing -> do
+ writeIORef haCharBuffer buf2
+ return '\r'
+ Just buf3 -> do
+ (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
+ if c2 == '\n'
+ then do
+ writeIORef haCharBuffer (bufferAdjustL i2 buf3)
+ return '\n'
+ else do
+ -- not a \r\n sequence, so just return the \r
+ writeIORef haCharBuffer buf3
+ return '\r'
+ else do
+ writeIORef haCharBuffer buf2
+ return c1
+
+-- ---------------------------------------------------------------------------
+-- hGetLine
+
+-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
+-- the duration.
+
+-- | Computation 'hGetLine' @hdl@ reads a line from the file or
+-- channel managed by @hdl@.
+--
+-- This operation may fail with:
+--
+-- * 'isEOFError' if the end of file is encountered when reading
+-- the /first/ character of the line.
+--
+-- If 'hGetLine' encounters end-of-file at any other point while reading
+-- in a line, it is treated as a line terminator and the (partial)
+-- line is returned.
+
+hGetLine :: Handle -> IO String
+hGetLine h =
+ wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
+ hGetLineBuffered handle_
+
+hGetLineBuffered :: Handle__ -> IO String
+hGetLineBuffered handle_@Handle__{..} = do
+ buf <- readIORef haCharBuffer
+ hGetLineBufferedLoop handle_ buf []
+
+hGetLineBufferedLoop :: Handle__
+ -> CharBuffer -> [String]
+ -> IO String
+hGetLineBufferedLoop handle_@Handle__{..}
+ buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
+ let
+ -- find the end-of-line character, if there is one
+ loop raw r
+ | r == w = return (False, w)
+ | otherwise = do
+ (c,r') <- readCharBuf raw r
+ if c == '\n'
+ then return (True, r) -- NB. not r': don't include the '\n'
+ else loop raw r'
+ in do
+ (eol, off) <- loop raw0 r0
+
+ debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
+
+ (xs,r') <- if haInputNL == CRLF
+ then unpack_nl raw0 r0 off ""
+ else do xs <- unpack raw0 r0 off ""
+ return (xs,off)
+
+ -- if eol == True, then off is the offset of the '\n'
+ -- otherwise off == w and the buffer is now empty.
+ if eol -- r' == off
+ then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
+ return (concat (reverse (xs:xss)))
+ else do
+ let buf1 = bufferAdjustL r' buf
+ maybe_buf <- maybeFillReadBuffer handle_ buf1
+ case maybe_buf of
+ -- Nothing indicates we caught an EOF, and we may have a
+ -- partial line to return.
+ Nothing -> do
+ -- we reached EOF. There might be a lone \r left
+ -- in the buffer, so check for that and
+ -- append it to the line if necessary.
+ --
+ let pre = if not (isEmptyBuffer buf1) then "\r" else ""
+ writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
+ let str = concat (reverse (pre:xs:xss))
+ if not (null str)
+ then return str
+ else ioe_EOF
+ Just new_buf ->
+ hGetLineBufferedLoop handle_ new_buf (xs:xss)
+
+maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
+maybeFillReadBuffer handle_ buf
+ = catch
+ (do buf' <- getSomeCharacters handle_ buf
+ return (Just buf')
+ )
+ (\e -> do if isEOFError e
+ then return Nothing
+ else ioError e)
+
+-- See GHC.IO.Buffer
+#define CHARBUF_UTF32
+-- #define CHARBUF_UTF16
+
+-- NB. performance-critical code: eyeball the Core.
+unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
+unpack !buf !r !w acc0
+ | r == w = return acc0
+ | otherwise =
+ withRawBuffer buf $ \pbuf ->
+ let
+ unpackRB acc !i
+ | i < r = return acc
+ | otherwise = do
+#ifdef CHARBUF_UTF16
+ -- reverse-order decoding of UTF-16
+ c2 <- peekElemOff pbuf i
+ if (c2 < 0xdc00 || c2 > 0xdffff)
+ then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
+ else do c1 <- peekElemOff pbuf (i-1)
+ let c = (fromIntegral c1 - 0xd800) * 0x400 +
+ (fromIntegral c2 - 0xdc00) + 0x10000
+ unpackRB (unsafeChr c : acc) (i-2)
+#else
+ c <- peekElemOff pbuf i
+ unpackRB (c:acc) (i-1)
+#endif
+ in
+ unpackRB acc0 (w-1)
+
+-- NB. performance-critical code: eyeball the Core.
+unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
+unpack_nl !buf !r !w acc0
+ | r == w = return (acc0, 0)
+ | otherwise =
+ withRawBuffer buf $ \pbuf ->
+ let
+ unpackRB acc !i
+ | i < r = return acc
+ | otherwise = do
+ c <- peekElemOff pbuf i
+ if (c == '\n' && i > r)
+ then do
+ c1 <- peekElemOff pbuf (i-1)
+ if (c1 == '\r')
+ then unpackRB ('\n':acc) (i-2)
+ else unpackRB ('\n':acc) (i-1)
+ else do
+ unpackRB (c:acc) (i-1)
+ in do
+ c <- peekElemOff pbuf (w-1)
+ if (c == '\r')
+ then do
+ -- If the last char is a '\r', we need to know whether or
+ -- not it is followed by a '\n', so leave it in the buffer
+ -- for now and just unpack the rest.
+ str <- unpackRB acc0 (w-2)
+ return (str, w-1)
+ else do
+ str <- unpackRB acc0 (w-1)
+ return (str, w)
+
+
+-- -----------------------------------------------------------------------------
+-- hGetContents
+
+-- hGetContents on a DuplexHandle only affects the read side: you can
+-- carry on writing to it afterwards.
+
+-- | Computation 'hGetContents' @hdl@ returns the list of characters
+-- corresponding to the unread portion of the channel or file managed
+-- by @hdl@, which is put into an intermediate state, /semi-closed/.
+-- In this state, @hdl@ is effectively closed,
+-- but items are read from @hdl@ on demand and accumulated in a special
+-- list returned by 'hGetContents' @hdl@.
+--
+-- Any operation that fails because a handle is closed,
+-- also fails if a handle is semi-closed. The only exception is 'hClose'.
+-- A semi-closed handle becomes closed:
+--
+-- * if 'hClose' is applied to it;
+--
+-- * if an I\/O error occurs when reading an item from the handle;
+--
+-- * or once the entire contents of the handle has been read.
+--
+-- Once a semi-closed handle becomes closed, the contents of the
+-- associated list becomes fixed. The contents of this final list is
+-- only partially specified: it will contain at least all the items of
+-- the stream that were evaluated prior to the handle becoming closed.
+--
+-- Any I\/O errors encountered while a handle is semi-closed are simply
+-- discarded.
+--
+-- This operation may fail with:
+--
+-- * 'isEOFError' if the end of file has been reached.
+
+hGetContents :: Handle -> IO String
+hGetContents handle =
+ wantReadableHandle "hGetContents" handle $ \handle_ -> do
+ xs <- lazyRead handle
+ return (handle_{ haType=SemiClosedHandle}, xs )
+
+-- Note that someone may close the semi-closed handle (or change its
+-- buffering), so each time these lazy read functions are pulled on,
+-- they have to check whether the handle has indeed been closed.
+
+lazyRead :: Handle -> IO String
+lazyRead handle =
+ unsafeInterleaveIO $
+ withHandle "lazyRead" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return (handle_, "")
+ SemiClosedHandle -> lazyReadBuffered handle handle_
+ _ -> ioException
+ (IOError (Just handle) IllegalOperation "lazyRead"
+ "illegal handle type" Nothing Nothing)
+
+lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
+lazyReadBuffered h handle_@Handle__{..} = do
+ buf <- readIORef haCharBuffer
+ catch
+ (do
+ buf'@Buffer{..} <- getSomeCharacters handle_ buf
+ lazy_rest <- lazyRead h
+ (s,r) <- if haInputNL == CRLF
+ then unpack_nl bufRaw bufL bufR lazy_rest
+ else do s <- unpack bufRaw bufL bufR lazy_rest
+ return (s,bufR)
+ writeIORef haCharBuffer (bufferAdjustL r buf')
+ return (handle_, s)
+ )
+ -- all I/O errors are discarded. Additionally, we close the handle.
+ (\e -> do (handle_', _) <- hClose_help handle_
+ debugIO ("hGetContents caught: " ++ show e)
+ -- We might have a \r cached in CRLF mode. So we
+ -- need to check for that and return it:
+ if not (isEmptyBuffer buf)
+ then return (handle_', "\r")
+ else return (handle_', "")
+ )
+
+-- ensure we have some characters in the buffer
+getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
+getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
+ case bufferElems buf of
+
+ -- buffer empty: read some more
+ 0 -> readTextDevice handle_ buf
+
+ -- if the buffer has a single '\r' in it and we're doing newline
+ -- translation: read some more
+ 1 | haInputNL == CRLF -> do
+ (c,_) <- readCharBuf bufRaw bufL
+ if c == '\r'
+ then do -- shuffle the '\r' to the beginning. This is only safe
+ -- if we're about to call readTextDevice, otherwise it
+ -- would mess up flushCharBuffer.
+ -- See [note Buffer Flushing], GHC.IO.Handle.Types
+ writeCharBuf bufRaw 0 '\r'
+ let buf' = buf{ bufL=0, bufR=1 }
+ readTextDevice handle_ buf'
+ else do
+ return buf
+
+ -- buffer has some chars in it already: just return it
+ _otherwise ->
+ return buf
+
+-- ---------------------------------------------------------------------------
+-- hPutChar
+
+-- | Computation '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@.
+--
+-- This operation may fail with:
+--
+-- * 'isFullError' if the device is full; or
+--
+-- * 'isPermissionError' if another system resource limit would be exceeded.
+
+hPutChar :: Handle -> Char -> IO ()
+hPutChar handle c = do
+ c `seq` return ()
+ wantWritableHandle "hPutChar" handle $ \ handle_ -> do
+ case haBufferMode handle_ of
+ LineBuffering -> hPutcBuffered handle_ True c
+ _other -> hPutcBuffered handle_ False c
+
+hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
+hPutcBuffered handle_@Handle__{..} is_line c = do
+ buf <- readIORef haCharBuffer
+ if c == '\n'
+ then do buf1 <- if haOutputNL == CRLF
+ then do
+ buf1 <- putc buf '\r'
+ putc buf1 '\n'
+ else do
+ putc buf '\n'
+ if is_line
+ then do
+ flushed_buf <- flushWriteBuffer_ handle_ buf1
+ writeIORef haCharBuffer flushed_buf
+ else
+ writeIORef haCharBuffer buf1
+ else do
+ buf1 <- putc buf c
+ writeIORef haCharBuffer buf1
+ where
+ putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
+ debugIO ("putc: " ++ summaryBuffer buf)
+ w' <- writeCharBuf raw w c
+ let buf' = buf{ bufR = w' }
+ if isFullCharBuffer buf'
+ then flushWriteBuffer_ handle_ buf'
+ else return buf'
+
+-- ---------------------------------------------------------------------------
+-- hPutStr
+
+-- We go to some trouble to avoid keeping the handle locked while we're
+-- evaluating the string argument to hPutStr, in case doing so triggers another
+-- I/O operation on the same handle which would lead to deadlock. The classic
+-- case is
+--
+-- putStr (trace "hello" "world")
+--
+-- so the basic scheme is this:
+--
+-- * copy the string into a fresh buffer,
+-- * "commit" the buffer to the handle.
+--
+-- Committing may involve simply copying the contents of the new
+-- buffer into the handle's buffer, flushing one or both buffers, or
+-- maybe just swapping the buffers over (if the handle's buffer was
+-- empty). See commitBuffer below.
+
+-- | Computation 'hPutStr' @hdl s@ writes the string
+-- @s@ to the file or channel managed by @hdl@.
+--
+-- This operation may fail with:
+--
+-- * 'isFullError' if the device is full; or
+--
+-- * 'isPermissionError' if another system resource limit would be exceeded.
+
+hPutStr :: Handle -> String -> IO ()
+hPutStr handle str = do
+ (buffer_mode, nl) <-
+ wantWritableHandle "hPutStr" handle $ \h_ -> do
+ bmode <- getSpareBuffer h_
+ return (bmode, haOutputNL h_)
+
+ case buffer_mode of
+ (NoBuffering, _) -> do
+ hPutChars handle str -- v. slow, but we don't care
+ (LineBuffering, buf) -> do
+ writeBlocks handle True nl buf str
+ (BlockBuffering _, buf) -> do
+ writeBlocks handle False nl buf str
+
+hPutChars :: Handle -> [Char] -> IO ()
+hPutChars _ [] = return ()
+hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
+
+getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
+getSpareBuffer Handle__{haCharBuffer=ref,
+ haBuffers=spare_ref,
+ haBufferMode=mode}
+ = do
+ case mode of
+ NoBuffering -> return (mode, error "no buffer!")
+ _ -> do
+ bufs <- readIORef spare_ref
+ buf <- readIORef ref
+ case bufs of
+ BufferListCons b rest -> do
+ writeIORef spare_ref rest
+ return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
+ BufferListNil -> do
+ new_buf <- newCharBuffer (bufSize buf) WriteBuffer
+ return (mode, new_buf)
+
+
+-- NB. performance-critical code: eyeball the Core.
+writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
+writeBlocks hdl line_buffered nl
+ buf@Buffer{ bufRaw=raw, bufSize=len } s =
+ let
+ shoveString :: Int -> [Char] -> IO ()
+ shoveString !n [] = do
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ return ()
+ shoveString !n (c:cs)
+ -- n+1 so we have enough room to write '\r\n' if necessary
+ | n + 1 >= len = do
+ new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
+ writeBlocks hdl line_buffered nl new_buf (c:cs)
+ | c == '\n' = do
+ n' <- if nl == CRLF
+ then do
+ n1 <- writeCharBuf raw n '\r'
+ writeCharBuf raw n1 '\n'
+ else do
+ writeCharBuf raw n c
+ if line_buffered
+ then do
+ new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
+ writeBlocks hdl line_buffered nl new_buf cs
+ else do
+ shoveString n' cs
+ | otherwise = do
+ n' <- writeCharBuf raw n c
+ shoveString n' cs
+ in
+ shoveString 0 s
+
+-- -----------------------------------------------------------------------------
+-- commitBuffer handle buf sz count flush release
+--
+-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
+-- 'count' bytes of data) to handle (handle must be block or line buffered).
+--
+-- Implementation:
+--
+-- for block/line buffering,
+-- 1. If there isn't room in the handle buffer, flush the handle
+-- buffer.
+--
+-- 2. If the handle buffer is empty,
+-- if flush,
+-- then write buf directly to the device.
+-- else swap the handle buffer with buf.
+--
+-- 3. If the handle buffer is non-empty, copy buf into the
+-- handle buffer. Then, if flush != 0, flush
+-- the buffer.
+
+commitBuffer
+ :: Handle -- handle to commit to
+ -> RawCharBuffer -> Int -- address and size (in bytes) of buffer
+ -> Int -- number of bytes of data in buffer
+ -> Bool -- True <=> flush the handle afterward
+ -> Bool -- release the buffer?
+ -> IO CharBuffer
+
+commitBuffer hdl !raw !sz !count flush release =
+ wantWritableHandle "commitAndReleaseBuffer" hdl $
+ commitBuffer' raw sz count flush release
+{-# NOINLINE commitBuffer #-}
+
+-- Explicitly lambda-lift this function to subvert GHC's full laziness
+-- optimisations, which otherwise tends to float out subexpressions
+-- past the \handle, which is really a pessimisation in this case because
+-- that lambda is a one-shot lambda.
+--
+-- Don't forget to export the function, to stop it being inlined too
+-- (this appears to be better than NOINLINE, because the strictness
+-- analyser still gets to worker-wrapper it).
+--
+-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
+--
+commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
+ -> IO CharBuffer
+commitBuffer' raw sz@(I# _) count@(I# _) flush release
+ handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
+
+ debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
+ ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
+
+ old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
+ <- readIORef ref
+
+ buf_ret <-
+ -- enough room in handle buffer?
+ if (not flush && (size - w > count))
+ -- The > is to be sure that we never exactly fill
+ -- up the buffer, which would require a flush. So
+ -- if copying the new data into the buffer would
+ -- make the buffer full, we just flush the existing
+ -- buffer and the new data immediately, rather than
+ -- copying before flushing.
+
+ -- not flushing, and there's enough room in the buffer:
+ -- just copy the data in and update bufR.
+ then do withRawBuffer raw $ \praw ->
+ copyToRawBuffer old_raw (w*charSize)
+ praw (fromIntegral (count*charSize))
+ writeIORef ref old_buf{ bufR = w + count }
+ return (emptyBuffer raw sz WriteBuffer)
+
+ -- else, we have to flush
+ else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
+
+ let this_buf =
+ Buffer{ bufRaw=raw, bufState=WriteBuffer,
+ bufL=0, bufR=count, bufSize=sz }
+
+ -- if: (a) we don't have to flush, and
+ -- (b) size(new buffer) == size(old buffer), and
+ -- (c) new buffer is not full,
+ -- we can just just swap them over...
+ if (not flush && sz == size && count /= sz)
+ then do
+ writeIORef ref this_buf
+ return flushed_buf
+
+ -- otherwise, we have to flush the new data too,
+ -- and start with a fresh buffer
+ else do
+ flushWriteBuffer_ handle_ this_buf
+ writeIORef ref flushed_buf
+ -- if the sizes were different, then allocate
+ -- a new buffer of the correct size.
+ if sz == size
+ then return (emptyBuffer raw sz WriteBuffer)
+ else newCharBuffer size WriteBuffer
+
+ -- release the buffer if necessary
+ case buf_ret of
+ Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
+ if release && buf_ret_sz == size
+ then do
+ spare_bufs <- readIORef spare_buf_ref
+ writeIORef spare_buf_ref
+ (BufferListCons buf_ret_raw spare_bufs)
+ return buf_ret
+ else
+ return buf_ret
+
+-- ---------------------------------------------------------------------------
+-- Reading/writing sequences of bytes.
+
+-- ---------------------------------------------------------------------------
+-- hPutBuf
+
+-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
+-- buffer @buf@ to the handle @hdl@. It returns ().
+--
+-- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
+-- writing the bytes directly to the underlying file or device.
+--
+-- This operation may fail with:
+--
+-- * 'ResourceVanished' if the handle is a pipe or socket, and the
+-- reading end is closed. (If this is a POSIX system, and the program
+-- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
+-- instead, whose default action is to terminate the program).
+
+hPutBuf :: Handle -- handle to write to
+ -> Ptr a -- address of buffer
+ -> Int -- number of bytes of data in buffer
+ -> IO ()
+hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
+
+hPutBufNonBlocking
+ :: Handle -- handle to write to
+ -> Ptr a -- address of buffer
+ -> Int -- number of bytes of data in buffer
+ -> IO Int -- returns: number of bytes written
+hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
+
+hPutBuf':: Handle -- handle to write to
+ -> Ptr a -- address of buffer
+ -> Int -- number of bytes of data in buffer
+ -> Bool -- allow blocking?
+ -> IO Int
+hPutBuf' handle ptr count can_block
+ | count == 0 = return 0
+ | count < 0 = illegalBufferSize handle "hPutBuf" count
+ | otherwise =
+ wantWritableHandle "hPutBuf" handle $
+ \ h_@Handle__{..} -> do
+ debugIO ("hPutBuf count=" ++ show count)
+ -- first flush the Char buffer if it is non-empty, then we
+ -- can work directly with the byte buffer
+ cbuf <- readIORef haCharBuffer
+ when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
+
+ r <- bufWrite h_ (castPtr ptr) count can_block
+
+ -- we must flush if this Handle is set to NoBuffering. If
+ -- it is set to LineBuffering, be conservative and flush
+ -- anyway (we didn't check for newlines in the data).
+ case haBufferMode of
+ BlockBuffering _ -> do return ()
+ _line_or_no_buffering -> do flushWriteBuffer h_
+ return r
+
+bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
+bufWrite h_@Handle__{..} ptr count can_block =
+ seq count $ do -- strictness hack
+ old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
+ <- readIORef haByteBuffer
+
+ -- enough room in handle buffer?
+ if (size - w > count)
+ -- There's enough room in the buffer:
+ -- just copy the data in and update bufR.
+ then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
+ copyToRawBuffer old_raw w ptr (fromIntegral count)
+ writeIORef haByteBuffer old_buf{ bufR = w + count }
+ return count
+
+ -- else, we have to flush
+ else do debugIO "hPutBuf: flushing first"
+ Buffered.flushWriteBuffer haDevice old_buf
+ -- TODO: we should do a non-blocking flush here
+ writeIORef haByteBuffer old_buf{bufL=0,bufR=0}
+ -- if we can fit in the buffer, then just loop
+ if count < size
+ then bufWrite h_ ptr count can_block
+ else if can_block
+ then do writeChunk h_ (castPtr ptr) count
+ return count
+ else writeChunkNonBlocking h_ (castPtr ptr) count
+
+writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
+writeChunk h_@Handle__{..} ptr bytes
+ | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
+ | otherwise = error "Todo: hPutBuf"
+
+writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
+writeChunkNonBlocking h_@Handle__{..} ptr bytes
+ | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
+ | otherwise = error "Todo: hPutBuf"
+
+-- ---------------------------------------------------------------------------
+-- hGetBuf
+
+-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
+-- into the buffer @buf@ until either EOF is reached or
+-- @count@ 8-bit bytes have been read.
+-- It returns the number of bytes actually read. This may be zero if
+-- EOF was reached before any data was read (or if @count@ is zero).
+--
+-- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
+-- using, and reads bytes directly from the underlying IO device.
+--
+-- 'hGetBuf' never raises an EOF exception, instead it returns a value
+-- smaller than @count@.
+--
+-- If the handle is a pipe or socket, and the writing end
+-- is closed, 'hGetBuf' will behave as if EOF was reached.
+--
+
+hGetBuf :: Handle -> Ptr a -> Int -> IO Int
+hGetBuf h ptr count
+ | count == 0 = return 0
+ | count < 0 = illegalBufferSize h "hGetBuf" count
+ | otherwise =
+ wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
+ flushCharReadBuffer h_
+ bufRead h_ (castPtr ptr) 0 count
+
+-- small reads go through the buffer, large reads are satisfied by
+-- taking data first from the buffer and then direct from the file
+-- descriptor.
+bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
+bufRead h_@Handle__{..} ptr so_far count =
+ seq so_far $ seq count $ do -- strictness hack
+ buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
+ if isEmptyBuffer buf
+ then if count > sz -- small read?
+ then do rest <- readChunk h_ ptr count
+ return (so_far + rest)
+ else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
+ if r == 0
+ then return so_far
+ else do writeIORef haByteBuffer buf'
+ bufRead h_ ptr so_far count
+ else do
+ let avail = w - r
+ if (count == avail)
+ then do
+ copyFromRawBuffer ptr raw r count
+ writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
+ return (so_far + count)
+ else do
+ if (count < avail)
+ then do
+ copyFromRawBuffer ptr raw r count
+ writeIORef haByteBuffer buf{ bufL = r + count }
+ return (so_far + count)
+ else do
+
+ copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
+ writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
+ let remaining = count - avail
+ so_far' = so_far + avail
+ ptr' = ptr `plusPtr` avail
+
+ if remaining < sz
+ then bufRead h_ ptr' so_far' remaining
+ else do
+
+ rest <- readChunk h_ ptr' remaining
+ return (so_far' + rest)
+
+readChunk :: Handle__ -> Ptr a -> Int -> IO Int
+readChunk h_@Handle__{..} ptr bytes
+ | Just fd <- cast haDevice = loop fd 0 bytes
+ | otherwise = error "ToDo: hGetBuf"
+ where
+ loop :: FD -> Int -> Int -> IO Int
+ loop fd off bytes | bytes <= 0 = return off
+ loop fd off bytes = do
+ r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
+ if r == 0
+ then return off
+ else loop fd (off + r) (bytes - r)
+
+-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
+-- into the buffer @buf@ until either EOF is reached, or
+-- @count@ 8-bit bytes have been read, or there is no more data available
+-- to read immediately.
+--
+-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
+-- never block waiting for data to become available, instead it returns
+-- only whatever data is available. To wait for data to arrive before
+-- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
+--
+-- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
+-- is currently using, and reads bytes directly from the underlying IO
+-- device.
+--
+-- If the handle is a pipe or socket, and the writing end
+-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
+--
+hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
+hGetBufNonBlocking h ptr count
+ | count == 0 = return 0
+ | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
+ | otherwise =
+ wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
+ flushCharReadBuffer h_
+ bufReadNonBlocking h_ (castPtr ptr) 0 count
+
+bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
+bufReadNonBlocking h_@Handle__{..} ptr so_far count =
+ seq so_far $ seq count $ do -- strictness hack
+ buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
+ if isEmptyBuffer buf
+ then if count > sz -- large read?
+ then do rest <- readChunkNonBlocking h_ ptr count
+ return (so_far + rest)
+ else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
+ case r of
+ Nothing -> return so_far
+ Just 0 -> return so_far
+ Just r -> do
+ writeIORef haByteBuffer buf'
+ bufReadNonBlocking h_ ptr so_far (min count r)
+ -- NOTE: new count is min count w'
+ -- so we will just copy the contents of the
+ -- buffer in the recursive call, and not
+ -- loop again.
+ else do
+ let avail = w - r
+ if (count == avail)
+ then do
+ copyFromRawBuffer ptr raw r count
+ writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
+ return (so_far + count)
+ else do
+ if (count < avail)
+ then do
+ copyFromRawBuffer ptr raw r count
+ writeIORef haByteBuffer buf{ bufL = r + count }
+ return (so_far + count)
+ else do
+
+ copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
+ writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
+ let remaining = count - avail
+ so_far' = so_far + avail
+ ptr' = ptr `plusPtr` avail
+
+ -- we haven't attempted to read anything yet if we get to here.
+ if remaining < sz
+ then bufReadNonBlocking h_ ptr' so_far' remaining
+ else do
+
+ rest <- readChunkNonBlocking h_ ptr' remaining
+ return (so_far' + rest)
+
+
+readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
+readChunkNonBlocking h_@Handle__{..} ptr bytes
+ | Just fd <- cast haDevice = do
+ m <- RawIO.readNonBlocking (fd::FD) ptr bytes
+ case m of
+ Nothing -> return 0
+ Just n -> return n
+ | otherwise = error "ToDo: hGetBuf"
+
+-- ---------------------------------------------------------------------------
+-- memcpy wrappers
+
+copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
+copyToRawBuffer raw off ptr bytes = do
+ withRawBuffer raw $ \praw ->
+ memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
+ return ()
+
+copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
+copyFromRawBuffer ptr raw off bytes = do
+ withRawBuffer raw $ \praw ->
+ memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
+ return ()
+
+foreign import ccall unsafe "memcpy"
+ memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
+
+-----------------------------------------------------------------------------
+-- Internal Utils
+
+illegalBufferSize :: Handle -> String -> Int -> IO a
+illegalBufferSize handle fn sz =
+ ioException (IOError (Just handle)
+ InvalidArgument fn
+ ("illegal buffer size " ++ showsPrec 9 sz [])
+ Nothing Nothing)
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Handle.Types
+-- Copyright : (c) The University of Glasgow, 1994-2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- Basic types for the implementation of IO Handles.
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Handle.Types (
+ Handle(..), Handle__(..), showHandle,
+ checkHandleInvariants,
+ BufferList(..),
+ HandleType(..),
+ isReadableHandleType, isWritableHandleType, isReadWriteHandleType,
+ BufferMode(..),
+ BufferCodec(..),
+ NewlineMode(..), Newline(..), nativeNewline,
+ universalNewlineMode, noNewlineTranslation, nativeNewlineMode
+ ) where
+
+#undef DEBUG
+
+import GHC.Base
+import GHC.MVar
+import GHC.IO
+import GHC.IO.Buffer
+import GHC.IO.BufferedIO
+import GHC.IO.Encoding.Types
+import GHC.IORef
+import Data.Maybe
+import GHC.Show
+import GHC.Read
+import GHC.Word
+import GHC.IO.Device
+import Data.Typeable
+
+-- ---------------------------------------------------------------------------
+-- Handle type
+
+-- A Handle is represented by (a reference to) a record
+-- containing the state of the I/O port/device. We record
+-- the following pieces of info:
+
+-- * type (read,write,closed etc.)
+-- * the underlying file descriptor
+-- * buffering mode
+-- * buffer, and spare buffers
+-- * user-friendly name (usually the
+-- FilePath used when IO.openFile was called)
+
+-- Note: when a Handle is garbage collected, we want to flush its buffer
+-- and close the OS file handle, so as to free up a (precious) resource.
+
+-- | Haskell defines operations to read and write characters from and to files,
+-- represented by values of type @Handle@. Each value of this type is a
+-- /handle/: a record used by the Haskell run-time system to /manage/ I\/O
+-- with file system objects. A handle has at least the following properties:
+--
+-- * whether it manages input or output or both;
+--
+-- * whether it is /open/, /closed/ or /semi-closed/;
+--
+-- * whether the object is seekable;
+--
+-- * whether buffering is disabled, or enabled on a line or block basis;
+--
+-- * a buffer (whose length may be zero).
+--
+-- Most handles will also have a current I\/O position indicating where the next
+-- input or output operation will occur. A handle is /readable/ if it
+-- manages only input or both input and output; likewise, it is /writable/ if
+-- it manages only output or both input and output. A handle is /open/ when
+-- first allocated.
+-- Once it is closed it can no longer be used for either input or output,
+-- though an implementation cannot re-use its storage while references
+-- remain to it. Handles are in the 'Show' and 'Eq' classes. The string
+-- produced by showing a handle is system dependent; it should include
+-- enough information to identify the handle for debugging. A handle is
+-- equal according to '==' only to itself; no attempt
+-- is made to compare the internal state of different handles for equality.
+--
+-- GHC note: a 'Handle' will be automatically closed when the garbage
+-- collector detects that it has become unreferenced by the program.
+-- However, relying on this behaviour is not generally recommended:
+-- the garbage collector is unpredictable. If possible, use explicit
+-- an explicit 'hClose' to close 'Handle's when they are no longer
+-- required. GHC does not currently attempt to free up file
+-- descriptors when they have run out, it is your responsibility to
+-- ensure that this doesn't happen.
+
+data Handle
+ = FileHandle -- A normal handle to a file
+ FilePath -- the file (used for error messages
+ -- only)
+ !(MVar Handle__)
+
+ | DuplexHandle -- A handle to a read/write stream
+ FilePath -- file for a FIFO, otherwise some
+ -- descriptive string (used for error
+ -- messages only)
+ !(MVar Handle__) -- The read side
+ !(MVar Handle__) -- The write side
+
+ deriving Typeable
+
+-- NOTES:
+-- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be
+-- seekable.
+
+instance Eq Handle where
+ (FileHandle _ h1) == (FileHandle _ h2) = h1 == h2
+ (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2
+ _ == _ = False
+
+data Handle__
+ = forall dev . (IODevice dev, BufferedIO dev, Typeable dev) =>
+ Handle__ {
+ haDevice :: !dev,
+ haType :: HandleType, -- type (read/write/append etc.)
+ haByteBuffer :: !(IORef (Buffer Word8)),
+ haBufferMode :: BufferMode,
+ haLastDecode :: !(IORef (Buffer Word8)),
+ haCharBuffer :: !(IORef (Buffer CharBufElem)), -- the current buffer
+ haBuffers :: !(IORef (BufferList CharBufElem)), -- spare buffers
+ haEncoder :: Maybe TextEncoder,
+ haDecoder :: Maybe TextDecoder,
+ haInputNL :: Newline,
+ haOutputNL :: Newline,
+ haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a
+ -- duplex handle.
+ }
+ deriving Typeable
+
+-- we keep a few spare buffers around in a handle to avoid allocating
+-- a new one for each hPutStr. These buffers are *guaranteed* to be the
+-- same size as the main buffer.
+data BufferList e
+ = BufferListNil
+ | BufferListCons (RawBuffer e) (BufferList e)
+
+-- Internally, we classify handles as being one
+-- of the following:
+
+data HandleType
+ = ClosedHandle
+ | SemiClosedHandle
+ | ReadHandle
+ | WriteHandle
+ | AppendHandle
+ | ReadWriteHandle
+
+isReadableHandleType :: HandleType -> Bool
+isReadableHandleType ReadHandle = True
+isReadableHandleType ReadWriteHandle = True
+isReadableHandleType _ = False
+
+isWritableHandleType :: HandleType -> Bool
+isWritableHandleType AppendHandle = True
+isWritableHandleType WriteHandle = True
+isWritableHandleType ReadWriteHandle = True
+isWritableHandleType _ = False
+
+isReadWriteHandleType :: HandleType -> Bool
+isReadWriteHandleType ReadWriteHandle{} = True
+isReadWriteHandleType _ = False
+
+-- INVARIANTS on Handles:
+--
+-- * A handle *always* has a buffer, even if it is only 1 character long
+-- (an unbuffered handle needs a 1 character buffer in order to support
+-- hLookAhead and hIsEOF).
+-- * In a read Handle, the byte buffer is always empty (we decode when reading)
+-- * In a wriite Handle, the Char buffer is always empty (we encode when writing)
+--
+checkHandleInvariants :: Handle__ -> IO ()
+#ifdef DEBUG
+checkHandleInvariants h_ = do
+ bbuf <- readIORef (haByteBuffer h_)
+ checkBuffer bbuf
+ cbuf <- readIORef (haCharBuffer h_)
+ checkBuffer cbuf
+#else
+checkHandleInvariants _ = return ()
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Buffering modes
+
+-- | Three kinds of buffering are supported: line-buffering,
+-- block-buffering or no-buffering. These modes have the following
+-- effects. For output, items are written out, or /flushed/,
+-- from the internal buffer according to the buffer mode:
+--
+-- * /line-buffering/: the entire output buffer is flushed
+-- whenever a newline is output, the buffer overflows,
+-- a 'System.IO.hFlush' is issued, or the handle is closed.
+--
+-- * /block-buffering/: the entire buffer is written out whenever it
+-- overflows, a 'System.IO.hFlush' is issued, or the handle is closed.
+--
+-- * /no-buffering/: output is written immediately, and never stored
+-- in the buffer.
+--
+-- An implementation is free to flush the buffer more frequently,
+-- but not less frequently, than specified above.
+-- The output buffer is emptied as soon as it has been written out.
+--
+-- Similarly, input occurs according to the buffer mode for the handle:
+--
+-- * /line-buffering/: when the buffer for the handle is not empty,
+-- the next item is obtained from the buffer; otherwise, when the
+-- buffer is empty, characters up to and including the next newline
+-- character are read into the buffer. No characters are available
+-- until the newline character is available or the buffer is full.
+--
+-- * /block-buffering/: when the buffer for the handle becomes empty,
+-- the next block of data is read into the buffer.
+--
+-- * /no-buffering/: the next input item is read and returned.
+-- The 'System.IO.hLookAhead' operation implies that even a no-buffered
+-- handle may require a one-character buffer.
+--
+-- The default buffering mode when a handle is opened is
+-- implementation-dependent and may depend on the file system object
+-- which is attached to that handle.
+-- For most implementations, physical files will normally be block-buffered
+-- and terminals will normally be line-buffered.
+
+data BufferMode
+ = NoBuffering -- ^ buffering is disabled if possible.
+ | LineBuffering
+ -- ^ line-buffering should be enabled if possible.
+ | BlockBuffering (Maybe Int)
+ -- ^ block-buffering should be enabled if possible.
+ -- The size of the buffer is @n@ items if the argument
+ -- is 'Just' @n@ and is otherwise implementation-dependent.
+ deriving (Eq, Ord, Read, Show)
+
+{-
+[note Buffering Implementation]
+
+Each Handle has two buffers: a byte buffer (haByteBuffer) and a Char
+buffer (haCharBuffer).
+
+[note Buffered Reading]
+
+For read Handles, bytes are read into the byte buffer, and immediately
+decoded into the Char buffer (see
+GHC.IO.Handle.Internals.readTextDevice). The only way there might be
+some data left in the byte buffer is if there is a partial multi-byte
+character sequence that cannot be decoded into a full character.
+
+Note that the buffering mode (haBufferMode) makes no difference when
+reading data into a Handle. When reading, we can always just read all
+the data there is available without blocking, decode it into the Char
+buffer, and then provide it immediately to the caller.
+
+[note Buffered Writing]
+
+Characters are written into the Char buffer by e.g. hPutStr. When the
+buffer is full, we call writeTextDevice, which encodes the Char buffer
+into the byte buffer, and then immediately writes it all out to the
+underlying device. The Char buffer will always be empty afterward.
+This might require multiple decoding/writing cycles.
+
+[note Buffer Sizing]
+
+Since the buffer mode makes no difference when reading, we can just
+use the default buffer size for both the byte and the Char buffer.
+Ineed, we must have room for at least one Char in the Char buffer,
+because we have to implement hLookAhead, which requires caching a Char
+in the Handle. Furthermore, when doing newline translation, we need
+room for at least two Chars in the read buffer, so we can spot the
+\r\n sequence.
+
+For writing, however, when the buffer mode is NoBuffering, we use a
+1-element Char buffer to force flushing of the buffer after each Char
+is read.
+
+[note Buffer Flushing]
+
+** Flushing the Char buffer
+
+We must be able to flush the Char buffer, in order to implement
+hSetEncoding, and things like hGetBuf which want to read raw bytes.
+
+Flushing the Char buffer on a write Handle is easy: just call
+writeTextDevice to encode and write the date.
+
+Flushing the Char buffer on a read Handle involves rewinding the byte
+buffer to the point representing the next Char in the Char buffer.
+This is done by
+
+ - remembering the state of the byte buffer *before* the last decode
+
+ - re-decoding the bytes that represent the chars already read from the
+ Char buffer. This gives us the point in the byte buffer that
+ represents the *next* Char to be read.
+
+In order for this to work, after readTextHandle we must NOT MODIFY THE
+CONTENTS OF THE BYTE OR CHAR BUFFERS, except to remove characters from
+the Char buffer.
+
+** Flushing the byte buffer
+
+The byte buffer can be flushed if the Char buffer has already been
+flushed (see above). For a read Handle, flushing the byte buffer
+means seeking the device back by the number of bytes in the buffer,
+and hence it is only possible on a seekable Handle.
+
+-}
+
+-- ---------------------------------------------------------------------------
+-- Newline translation
+
+-- | The representation of a newline in the external file or stream.
+data Newline = LF -- ^ "\n"
+ | CRLF -- ^ "\r\n"
+ deriving Eq
+
+-- | Specifies the translation, if any, of newline characters between
+-- internal Strings and the external file or stream. Haskell Strings
+-- are assumed to represent newlines with the '\n' character; the
+-- newline mode specifies how to translate '\n' on output, and what to
+-- translate into '\n' on input.
+data NewlineMode
+ = NewlineMode { inputNL :: Newline,
+ -- ^ the representation of newlines on input
+ outputNL :: Newline
+ -- ^ the representation of newlines on output
+ }
+ deriving Eq
+
+-- | The native newline representation for the current platform
+nativeNewline :: Newline
+#ifdef mingw32_HOST_OS
+nativeNewline = CRLF
+#else
+nativeNewline = LF
+#endif
+
+-- | Map "\r\n" into "\n" on input, and "\n" to the native newline
+-- represetnation on output. This mode can be used on any platform, and
+-- works with text files using any newline convention. The downside is
+-- that @readFile >>= writeFile@ might yield a different file.
+--
+-- > universalNewlineMode = NewlineMode { inputNL = CRLF,
+-- > outputNL = nativeNewline }
+--
+universalNewlineMode :: NewlineMode
+universalNewlineMode = NewlineMode { inputNL = CRLF,
+ outputNL = nativeNewline }
+
+-- | Use the native newline representation on both input and output
+--
+-- > nativeNewlineMode = NewlineMode { inputNL = nativeNewline
+-- > outputNL = nativeNewline }
+--
+nativeNewlineMode :: NewlineMode
+nativeNewlineMode = NewlineMode { inputNL = nativeNewline,
+ outputNL = nativeNewline }
+
+-- | Do no newline translation at all.
+--
+-- > noNewlineTranslation = NewlineMode { inputNL = LF, outputNL = LF }
+--
+noNewlineTranslation :: NewlineMode
+noNewlineTranslation = NewlineMode { inputNL = LF, outputNL = LF }
+
+-- ---------------------------------------------------------------------------
+-- Show instance for Handles
+
+-- handle types are 'show'n when printing error msgs, so
+-- we provide a more user-friendly Show instance for it
+-- than the derived one.
+
+instance Show HandleType where
+ showsPrec _ t =
+ case t of
+ ClosedHandle -> showString "closed"
+ SemiClosedHandle -> showString "semi-closed"
+ ReadHandle -> showString "readable"
+ WriteHandle -> showString "writable"
+ AppendHandle -> showString "writable (append)"
+ ReadWriteHandle -> showString "read-writable"
+
+instance Show Handle where
+ showsPrec _ (FileHandle file _) = showHandle file
+ showsPrec _ (DuplexHandle file _ _) = showHandle file
+
+showHandle :: FilePath -> String -> String
+showHandle file = showString "{handle: " . showString file . showString "}"
--- /dev/null
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.IOMode
+-- Copyright : (c) The University of Glasgow, 1994-2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- The IOMode type
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.IOMode (IOMode(..)) where
+
+import GHC.Base
+import GHC.Show
+import GHC.Read
+import GHC.Arr
+import GHC.Enum
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IOArray
+-- Copyright : (c) The University of Glasgow 2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- The IOArray type
+--
+-----------------------------------------------------------------------------
+
+module GHC.IOArray (
+ IOArray(..),
+ newIOArray, unsafeReadIOArray, unsafeWriteIOArray,
+ readIOArray, writeIOArray,
+ boundsIOArray
+ ) where
+
+import GHC.Base
+import GHC.IO
+import GHC.Arr
+
+-- ---------------------------------------------------------------------------
+-- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad.
+-- The type arguments are as follows:
+--
+-- * @i@: the index type of the array (should be an instance of 'Ix')
+--
+-- * @e@: the element type of the array.
+--
+--
+
+newtype IOArray i e = IOArray (STArray RealWorld i e)
+
+-- explicit instance because Haddock can't figure out a derived one
+instance Eq (IOArray i e) where
+ IOArray x == IOArray y = x == y
+
+-- |Build a new 'IOArray'
+newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e)
+{-# INLINE newIOArray #-}
+newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)}
+
+-- | Read a value from an 'IOArray'
+unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e
+{-# INLINE unsafeReadIOArray #-}
+unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i)
+
+-- | Write a new value into an 'IOArray'
+unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO ()
+{-# INLINE unsafeWriteIOArray #-}
+unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e)
+
+-- | Read a value from an 'IOArray'
+readIOArray :: Ix i => IOArray i e -> i -> IO e
+readIOArray (IOArray marr) i = stToIO (readSTArray marr i)
+
+-- | Write a new value into an 'IOArray'
+writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()
+writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)
+
+{-# INLINE boundsIOArray #-}
+boundsIOArray :: IOArray i e -> (i,i)
+boundsIOArray (IOArray marr) = boundsSTArray marr
--- /dev/null
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IOBase
+-- Copyright : (c) The University of Glasgow 1994-2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- Backwards-compatibility interface
+--
+-----------------------------------------------------------------------------
+
+
+module GHC.IOBase {-# DEPRECATED "use GHC.IO instead" #-} (
+ IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO,
+ unsafePerformIO, unsafeInterleaveIO,
+ unsafeDupablePerformIO, unsafeDupableInterleaveIO,
+ noDuplicate,
+
+ -- To and from from ST
+ stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
+
+ -- References
+ IORef(..), newIORef, readIORef, writeIORef,
+ IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
+ MVar(..),
+
+ -- Handles, file descriptors,
+ FilePath,
+ Handle(..), Handle__(..), HandleType(..), IOMode(..), FD,
+ isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,
+
+ -- Buffers
+ -- Buffer(..), RawBuffer, BufferState(..),
+ BufferList(..), BufferMode(..),
+ --bufferIsWritable, bufferEmpty, bufferFull,
+
+ -- Exceptions
+ Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
+ stackOverflow, heapOverflow, ioException,
+ IOError, IOException(..), IOErrorType(..), ioError, userError,
+ ExitCode(..),
+ throwIO, block, unblock, blocked, catchAny, catchException,
+ evaluate,
+ ErrorCall(..), AssertionFailed(..), assertError, untangle,
+ BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..),
+ blockedOnDeadMVar, blockedIndefinitely
+ ) where
+
+import GHC.Exception
+import GHC.IO
+import GHC.IO.Handle.Types
+import GHC.IO.IOMode
+import GHC.IO.Exception
+import GHC.IOArray
+import GHC.IORef
+import GHC.MVar
+import Foreign.C.Types
+
+type FD = CInt
+++ /dev/null
-\begin{code}
-{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module : GHC.IOBase
--- Copyright : (c) The University of Glasgow 1994-2002
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Definitions for the 'IO' monad and its friends.
---
------------------------------------------------------------------------------
-
--- #hide
-module GHC.IOBase(
- IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO,
- unsafePerformIO, unsafeInterleaveIO,
- unsafeDupablePerformIO, unsafeDupableInterleaveIO,
- noDuplicate,
-
- -- To and from from ST
- stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
-
- -- References
- IORef(..), newIORef, readIORef, writeIORef,
- IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray,
- unsafeWriteIOArray, boundsIOArray,
- MVar(..),
-
- -- Handles, file descriptors,
- FilePath,
- Handle(..), Handle__(..), HandleType(..), IOMode(..), FD,
- isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,
-
- -- Buffers
- Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..),
- bufferIsWritable, bufferEmpty, bufferFull,
-
- -- Exceptions
- Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
- stackOverflow, heapOverflow, ioException,
- IOError, IOException(..), IOErrorType(..), ioError, userError,
- ExitCode(..),
- throwIO, block, unblock, blocked, catchAny, catchException,
- evaluate,
- ErrorCall(..), AssertionFailed(..), assertError, untangle,
- BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..),
- blockedOnDeadMVar, blockedIndefinitely
- ) where
-
-import GHC.ST
-import GHC.Arr -- to derive Ix class
-import GHC.Enum -- to derive Enum class
-import GHC.STRef
-import GHC.Base
--- import GHC.Num -- To get fromInteger etc, needed because of -XNoImplicitPrelude
-import Data.Maybe ( Maybe(..) )
-import GHC.Show
-import GHC.List
-import GHC.Read
-import Foreign.C.Types (CInt)
-import GHC.Exception
-
-#ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Typeable ( Typeable )
-#endif
-
--- ---------------------------------------------------------------------------
--- The IO Monad
-
-{-
-The IO Monad is just an instance of the ST monad, where the state is
-the real world. We use the exception mechanism (in GHC.Exception) to
-implement IO exceptions.
-
-NOTE: The IO representation is deeply wired in to various parts of the
-system. The following list may or may not be exhaustive:
-
-Compiler - types of various primitives in PrimOp.lhs
-
-RTS - forceIO (StgMiscClosures.hc)
- - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
- (Exceptions.hc)
- - raiseAsync (Schedule.c)
-
-Prelude - GHC.IOBase.lhs, and several other places including
- GHC.Exception.lhs.
-
-Libraries - parts of hslibs/lang.
-
---SDM
--}
-
-{-|
-A value of type @'IO' a@ is a computation which, when performed,
-does some I\/O before returning a value of type @a@.
-
-There is really only one way to \"perform\" an I\/O action: bind it to
-@Main.main@ in your program. When your program is run, the I\/O will
-be performed. It isn't possible to perform I\/O from an arbitrary
-function, unless that function is itself in the 'IO' monad and called
-at some point, directly or indirectly, from @Main.main@.
-
-'IO' is a monad, so 'IO' actions can be combined using either the do-notation
-or the '>>' and '>>=' operations from the 'Monad' class.
--}
-newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
-
-unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
-unIO (IO a) = a
-
-instance Functor IO where
- fmap f x = x >>= (return . f)
-
-instance Monad IO where
- {-# INLINE return #-}
- {-# INLINE (>>) #-}
- {-# INLINE (>>=) #-}
- m >> k = m >>= \ _ -> k
- return x = returnIO x
-
- m >>= k = bindIO m k
- fail s = failIO s
-
-failIO :: String -> IO a
-failIO s = ioError (userError s)
-
-liftIO :: IO a -> State# RealWorld -> STret RealWorld a
-liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
-
-bindIO :: IO a -> (a -> IO b) -> IO b
-bindIO (IO m) k = IO ( \ s ->
- case m s of
- (# new_s, a #) -> unIO (k a) new_s
- )
-
-thenIO :: IO a -> IO b -> IO b
-thenIO (IO m) k = IO ( \ s ->
- case m s of
- (# new_s, _ #) -> unIO k new_s
- )
-
-returnIO :: a -> IO a
-returnIO x = IO (\ s -> (# s, x #))
-
--- ---------------------------------------------------------------------------
--- Coercions between IO and ST
-
--- | A monad transformer embedding strict state transformers in the 'IO'
--- monad. The 'RealWorld' parameter indicates that the internal state
--- used by the 'ST' computation is a special one supplied by the 'IO'
--- monad, and thus distinct from those used by invocations of 'runST'.
-stToIO :: ST RealWorld a -> IO a
-stToIO (ST m) = IO m
-
-ioToST :: IO a -> ST RealWorld a
-ioToST (IO m) = (ST m)
-
--- This relies on IO and ST having the same representation modulo the
--- constraint on the type of the state
---
-unsafeIOToST :: IO a -> ST s a
-unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s
-
-unsafeSTToIO :: ST s a -> IO a
-unsafeSTToIO (ST m) = IO (unsafeCoerce# m)
-
--- ---------------------------------------------------------------------------
--- Unsafe IO operations
-
-{-|
-This is the \"back door\" into the 'IO' monad, allowing
-'IO' computation to be performed at any time. For
-this to be safe, the 'IO' computation should be
-free of side effects and independent of its environment.
-
-If the I\/O computation wrapped in 'unsafePerformIO'
-performs side effects, then the relative order in which those side
-effects take place (relative to the main I\/O trunk, or other calls to
-'unsafePerformIO') is indeterminate. You have to be careful when
-writing and compiling modules that use 'unsafePerformIO':
-
- * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@
- that calls 'unsafePerformIO'. If the call is inlined,
- the I\/O may be performed more than once.
-
- * Use the compiler flag @-fno-cse@ to prevent common sub-expression
- elimination being performed on the module, which might combine
- two side effects that were meant to be separate. A good example
- is using multiple global variables (like @test@ in the example below).
-
- * Make sure that the either you switch off let-floating, or that the
- call to 'unsafePerformIO' cannot float outside a lambda. For example,
- if you say:
- @
- f x = unsafePerformIO (newIORef [])
- @
- you may get only one reference cell shared between all calls to @f@.
- Better would be
- @
- f x = unsafePerformIO (newIORef [x])
- @
- because now it can't float outside the lambda.
-
-It is less well known that
-'unsafePerformIO' is not type safe. For example:
-
-> test :: IORef [a]
-> test = unsafePerformIO $ newIORef []
->
-> main = do
-> writeIORef test [42]
-> bang <- readIORef test
-> print (bang :: [Char])
-
-This program will core dump. This problem with polymorphic references
-is well known in the ML community, and does not arise with normal
-monadic use of references. There is no easy way to make it impossible
-once you use 'unsafePerformIO'. Indeed, it is
-possible to write @coerce :: a -> b@ with the
-help of 'unsafePerformIO'. So be careful!
--}
-unsafePerformIO :: IO a -> a
-unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
-
-{-|
-This version of 'unsafePerformIO' is slightly more efficient,
-because it omits the check that the IO is only being performed by a
-single thread. Hence, when you write 'unsafeDupablePerformIO',
-there is a possibility that the IO action may be performed multiple
-times (on a multiprocessor), and you should therefore ensure that
-it gives the same results each time.
--}
-{-# NOINLINE unsafeDupablePerformIO #-}
-unsafeDupablePerformIO :: IO a -> a
-unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
-
--- Why do we NOINLINE unsafeDupablePerformIO? See the comment with
--- GHC.ST.runST. Essentially the issue is that the IO computation
--- inside unsafePerformIO must be atomic: it must either all run, or
--- not at all. If we let the compiler see the application of the IO
--- to realWorld#, it might float out part of the IO.
-
--- Why is there a call to 'lazy' in unsafeDupablePerformIO?
--- If we don't have it, the demand analyser discovers the following strictness
--- for unsafeDupablePerformIO: C(U(AV))
--- But then consider
--- unsafeDupablePerformIO (\s -> let r = f x in
--- case writeIORef v r s of (# s1, _ #) ->
--- (# s1, r #)
--- The strictness analyser will find that the binding for r is strict,
--- (becuase of uPIO's strictness sig), and so it'll evaluate it before
--- doing the writeIORef. This actually makes tests/lib/should_run/memo002
--- get a deadlock!
---
--- Solution: don't expose the strictness of unsafeDupablePerformIO,
--- by hiding it with 'lazy'
-
-{-|
-'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
-When passed a value of type @IO a@, the 'IO' will only be performed
-when the value of the @a@ is demanded. This is used to implement lazy
-file reading, see 'System.IO.hGetContents'.
--}
-{-# INLINE unsafeInterleaveIO #-}
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)
-
--- We believe that INLINE on unsafeInterleaveIO is safe, because the
--- state from this IO thread is passed explicitly to the interleaved
--- IO, so it cannot be floated out and shared.
-
-{-# INLINE unsafeDupableInterleaveIO #-}
-unsafeDupableInterleaveIO :: IO a -> IO a
-unsafeDupableInterleaveIO (IO m)
- = IO ( \ s -> let
- r = case m s of (# _, res #) -> res
- in
- (# s, r #))
-
-{-|
-Ensures that the suspensions under evaluation by the current thread
-are unique; that is, the current thread is not evaluating anything
-that is also under evaluation by another thread that has also executed
-'noDuplicate'.
-
-This operation is used in the definition of 'unsafePerformIO' to
-prevent the IO action from being executed multiple times, which is usually
-undesirable.
--}
-noDuplicate :: IO ()
-noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)
-
--- ---------------------------------------------------------------------------
--- Handle type
-
-data MVar a = MVar (MVar# RealWorld a)
-{- ^
-An 'MVar' (pronounced \"em-var\") is a synchronising variable, used
-for communication between concurrent threads. It can be thought of
-as a a box, which may be empty or full.
--}
-
--- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module
-instance Eq (MVar a) where
- (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
-
--- A Handle is represented by (a reference to) a record
--- containing the state of the I/O port/device. We record
--- the following pieces of info:
-
--- * type (read,write,closed etc.)
--- * the underlying file descriptor
--- * buffering mode
--- * buffer, and spare buffers
--- * user-friendly name (usually the
--- FilePath used when IO.openFile was called)
-
--- Note: when a Handle is garbage collected, we want to flush its buffer
--- and close the OS file handle, so as to free up a (precious) resource.
-
--- | Haskell defines operations to read and write characters from and to files,
--- represented by values of type @Handle@. Each value of this type is a
--- /handle/: a record used by the Haskell run-time system to /manage/ I\/O
--- with file system objects. A handle has at least the following properties:
---
--- * whether it manages input or output or both;
---
--- * whether it is /open/, /closed/ or /semi-closed/;
---
--- * whether the object is seekable;
---
--- * whether buffering is disabled, or enabled on a line or block basis;
---
--- * a buffer (whose length may be zero).
---
--- Most handles will also have a current I\/O position indicating where the next
--- input or output operation will occur. A handle is /readable/ if it
--- manages only input or both input and output; likewise, it is /writable/ if
--- it manages only output or both input and output. A handle is /open/ when
--- first allocated.
--- Once it is closed it can no longer be used for either input or output,
--- though an implementation cannot re-use its storage while references
--- remain to it. Handles are in the 'Show' and 'Eq' classes. The string
--- produced by showing a handle is system dependent; it should include
--- enough information to identify the handle for debugging. A handle is
--- equal according to '==' only to itself; no attempt
--- is made to compare the internal state of different handles for equality.
---
--- GHC note: a 'Handle' will be automatically closed when the garbage
--- collector detects that it has become unreferenced by the program.
--- However, relying on this behaviour is not generally recommended:
--- the garbage collector is unpredictable. If possible, use explicit
--- an explicit 'hClose' to close 'Handle's when they are no longer
--- required. GHC does not currently attempt to free up file
--- descriptors when they have run out, it is your responsibility to
--- ensure that this doesn't happen.
-
-data Handle
- = FileHandle -- A normal handle to a file
- FilePath -- the file (invariant)
- !(MVar Handle__)
-
- | DuplexHandle -- A handle to a read/write stream
- FilePath -- file for a FIFO, otherwise some
- -- descriptive string.
- !(MVar Handle__) -- The read side
- !(MVar Handle__) -- The write side
-
--- NOTES:
--- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be
--- seekable.
-
-instance Eq Handle where
- (FileHandle _ h1) == (FileHandle _ h2) = h1 == h2
- (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2
- _ == _ = False
-
-type FD = CInt
-
-data Handle__
- = Handle__ {
- haFD :: !FD, -- file descriptor
- haType :: HandleType, -- type (read/write/append etc.)
- haIsBin :: Bool, -- binary mode?
- haIsStream :: Bool, -- Windows : is this a socket?
- -- Unix : is O_NONBLOCK set?
- haBufferMode :: BufferMode, -- buffer contains read/write data?
- haBuffer :: !(IORef Buffer), -- the current buffer
- haBuffers :: !(IORef BufferList), -- spare buffers
- haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a
- -- duplex handle.
- }
-
--- ---------------------------------------------------------------------------
--- Buffers
-
--- The buffer is represented by a mutable variable containing a
--- record, where the record contains the raw buffer and the start/end
--- points of the filled portion. We use a mutable variable so that
--- the common operation of writing (or reading) some data from (to)
--- the buffer doesn't need to modify, and hence copy, the handle
--- itself, it just updates the buffer.
-
--- There will be some allocation involved in a simple hPutChar in
--- order to create the new Buffer structure (below), but this is
--- relatively small, and this only has to be done once per write
--- operation.
-
--- The buffer contains its size - we could also get the size by
--- calling sizeOfMutableByteArray# on the raw buffer, but that tends
--- to be rounded up to the nearest Word.
-
-type RawBuffer = MutableByteArray# RealWorld
-
--- INVARIANTS on a Buffer:
---
--- * A handle *always* has a buffer, even if it is only 1 character long
--- (an unbuffered handle needs a 1 character buffer in order to support
--- hLookAhead and hIsEOF).
--- * r <= w
--- * if r == w, then r == 0 && w == 0
--- * if state == WriteBuffer, then r == 0
--- * a write buffer is never full. If an operation
--- fills up the buffer, it will always flush it before
--- returning.
--- * a read buffer may be full as a result of hLookAhead. In normal
--- operation, a read buffer always has at least one character of space.
-
-data Buffer
- = Buffer {
- bufBuf :: RawBuffer,
- bufRPtr :: !Int,
- bufWPtr :: !Int,
- bufSize :: !Int,
- bufState :: BufferState
- }
-
-data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
-
--- we keep a few spare buffers around in a handle to avoid allocating
--- a new one for each hPutStr. These buffers are *guaranteed* to be the
--- same size as the main buffer.
-data BufferList
- = BufferListNil
- | BufferListCons RawBuffer BufferList
-
-
-bufferIsWritable :: Buffer -> Bool
-bufferIsWritable Buffer{ bufState=WriteBuffer } = True
-bufferIsWritable _other = False
-
-bufferEmpty :: Buffer -> Bool
-bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w
-
--- only makes sense for a write buffer
-bufferFull :: Buffer -> Bool
-bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
-
--- Internally, we classify handles as being one
--- of the following:
-
-data HandleType
- = ClosedHandle
- | SemiClosedHandle
- | ReadHandle
- | WriteHandle
- | AppendHandle
- | ReadWriteHandle
-
-isReadableHandleType :: HandleType -> Bool
-isReadableHandleType ReadHandle = True
-isReadableHandleType ReadWriteHandle = True
-isReadableHandleType _ = False
-
-isWritableHandleType :: HandleType -> Bool
-isWritableHandleType AppendHandle = True
-isWritableHandleType WriteHandle = True
-isWritableHandleType ReadWriteHandle = True
-isWritableHandleType _ = False
-
-isReadWriteHandleType :: HandleType -> Bool
-isReadWriteHandleType ReadWriteHandle{} = True
-isReadWriteHandleType _ = False
-
--- | File and directory names are values of type 'String', whose precise
--- meaning is operating system dependent. Files can be opened, yielding a
--- handle which can then be used to operate on the contents of that file.
-
-type FilePath = String
-
--- ---------------------------------------------------------------------------
--- Buffering modes
-
--- | Three kinds of buffering are supported: line-buffering,
--- block-buffering or no-buffering. These modes have the following
--- effects. For output, items are written out, or /flushed/,
--- from the internal buffer according to the buffer mode:
---
--- * /line-buffering/: the entire output buffer is flushed
--- whenever a newline is output, the buffer overflows,
--- a 'System.IO.hFlush' is issued, or the handle is closed.
---
--- * /block-buffering/: the entire buffer is written out whenever it
--- overflows, a 'System.IO.hFlush' is issued, or the handle is closed.
---
--- * /no-buffering/: output is written immediately, and never stored
--- in the buffer.
---
--- An implementation is free to flush the buffer more frequently,
--- but not less frequently, than specified above.
--- The output buffer is emptied as soon as it has been written out.
---
--- Similarly, input occurs according to the buffer mode for the handle:
---
--- * /line-buffering/: when the buffer for the handle is not empty,
--- the next item is obtained from the buffer; otherwise, when the
--- buffer is empty, characters up to and including the next newline
--- character are read into the buffer. No characters are available
--- until the newline character is available or the buffer is full.
---
--- * /block-buffering/: when the buffer for the handle becomes empty,
--- the next block of data is read into the buffer.
---
--- * /no-buffering/: the next input item is read and returned.
--- The 'System.IO.hLookAhead' operation implies that even a no-buffered
--- handle may require a one-character buffer.
---
--- The default buffering mode when a handle is opened is
--- implementation-dependent and may depend on the file system object
--- which is attached to that handle.
--- For most implementations, physical files will normally be block-buffered
--- and terminals will normally be line-buffered.
-
-data BufferMode
- = NoBuffering -- ^ buffering is disabled if possible.
- | LineBuffering
- -- ^ line-buffering should be enabled if possible.
- | BlockBuffering (Maybe Int)
- -- ^ block-buffering should be enabled if possible.
- -- The size of the buffer is @n@ items if the argument
- -- is 'Just' @n@ and is otherwise implementation-dependent.
- deriving (Eq, Ord, Read, Show)
-
--- ---------------------------------------------------------------------------
--- IORefs
-
--- |A mutable variable in the 'IO' monad
-newtype IORef a = IORef (STRef RealWorld a)
-
--- explicit instance because Haddock can't figure out a derived one
-instance Eq (IORef a) where
- IORef x == IORef y = x == y
-
--- |Build a new 'IORef'
-newIORef :: a -> IO (IORef a)
-newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
-
--- |Read the value of an 'IORef'
-readIORef :: IORef a -> IO a
-readIORef (IORef var) = stToIO (readSTRef var)
-
--- |Write a new value into an 'IORef'
-writeIORef :: IORef a -> a -> IO ()
-writeIORef (IORef var) v = stToIO (writeSTRef var v)
-
--- ---------------------------------------------------------------------------
--- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad.
--- The type arguments are as follows:
---
--- * @i@: the index type of the array (should be an instance of 'Ix')
---
--- * @e@: the element type of the array.
---
---
-
-newtype IOArray i e = IOArray (STArray RealWorld i e)
-
--- explicit instance because Haddock can't figure out a derived one
-instance Eq (IOArray i e) where
- IOArray x == IOArray y = x == y
-
--- |Build a new 'IOArray'
-newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e)
-{-# INLINE newIOArray #-}
-newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)}
-
--- | Read a value from an 'IOArray'
-unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e
-{-# INLINE unsafeReadIOArray #-}
-unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i)
-
--- | Write a new value into an 'IOArray'
-unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO ()
-{-# INLINE unsafeWriteIOArray #-}
-unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e)
-
--- | Read a value from an 'IOArray'
-readIOArray :: Ix i => IOArray i e -> i -> IO e
-readIOArray (IOArray marr) i = stToIO (readSTArray marr i)
-
--- | Write a new value into an 'IOArray'
-writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()
-writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)
-
-{-# INLINE boundsIOArray #-}
-boundsIOArray :: IOArray i e -> (i,i)
-boundsIOArray (IOArray marr) = boundsSTArray marr
-
--- ---------------------------------------------------------------------------
--- Show instance for Handles
-
--- handle types are 'show'n when printing error msgs, so
--- we provide a more user-friendly Show instance for it
--- than the derived one.
-
-instance Show HandleType where
- showsPrec _ t =
- case t of
- ClosedHandle -> showString "closed"
- SemiClosedHandle -> showString "semi-closed"
- ReadHandle -> showString "readable"
- WriteHandle -> showString "writable"
- AppendHandle -> showString "writable (append)"
- ReadWriteHandle -> showString "read-writable"
-
-instance Show Handle where
- showsPrec _ (FileHandle file _) = showHandle file
- showsPrec _ (DuplexHandle file _ _) = showHandle file
-
-showHandle :: FilePath -> String -> String
-showHandle file = showString "{handle: " . showString file . showString "}"
-
--- ------------------------------------------------------------------------
--- Exception datatypes and operations
-
--- |The thread is blocked on an @MVar@, but there are no other references
--- to the @MVar@ so it can't ever continue.
-data BlockedOnDeadMVar = BlockedOnDeadMVar
- deriving Typeable
-
-instance Exception BlockedOnDeadMVar
-
-instance Show BlockedOnDeadMVar where
- showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
-
-blockedOnDeadMVar :: SomeException -- for the RTS
-blockedOnDeadMVar = toException BlockedOnDeadMVar
-
------
-
--- |The thread is awiting to retry an STM transaction, but there are no
--- other references to any @TVar@s involved, so it can't ever continue.
-data BlockedIndefinitely = BlockedIndefinitely
- deriving Typeable
-
-instance Exception BlockedIndefinitely
-
-instance Show BlockedIndefinitely where
- showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
-
-blockedIndefinitely :: SomeException -- for the RTS
-blockedIndefinitely = toException BlockedIndefinitely
-
------
-
--- |There are no runnable threads, so the program is deadlocked.
--- The @Deadlock@ exception is raised in the main thread only.
-data Deadlock = Deadlock
- deriving Typeable
-
-instance Exception Deadlock
-
-instance Show Deadlock where
- showsPrec _ Deadlock = showString "<<deadlock>>"
-
------
-
--- |Exceptions generated by 'assert'. The @String@ gives information
--- about the source location of the assertion.
-data AssertionFailed = AssertionFailed String
- deriving Typeable
-
-instance Exception AssertionFailed
-
-instance Show AssertionFailed where
- showsPrec _ (AssertionFailed err) = showString err
-
------
-
--- |Asynchronous exceptions.
-data AsyncException
- = StackOverflow
- -- ^The current thread\'s stack exceeded its limit.
- -- Since an exception has been raised, the thread\'s stack
- -- will certainly be below its limit again, but the
- -- programmer should take remedial action
- -- immediately.
- | HeapOverflow
- -- ^The program\'s heap is reaching its limit, and
- -- the program should take action to reduce the amount of
- -- live data it has. Notes:
- --
- -- * It is undefined which thread receives this exception.
- --
- -- * GHC currently does not throw 'HeapOverflow' exceptions.
- | ThreadKilled
- -- ^This exception is raised by another thread
- -- calling 'Control.Concurrent.killThread', or by the system
- -- if it needs to terminate the thread for some
- -- reason.
- | UserInterrupt
- -- ^This exception is raised by default in the main thread of
- -- the program when the user requests to terminate the program
- -- via the usual mechanism(s) (e.g. Control-C in the console).
- deriving (Eq, Ord, Typeable)
-
-instance Exception AsyncException
-
--- | Exceptions generated by array operations
-data ArrayException
- = IndexOutOfBounds String
- -- ^An attempt was made to index an array outside
- -- its declared bounds.
- | UndefinedElement String
- -- ^An attempt was made to evaluate an element of an
- -- array that had not been initialized.
- deriving (Eq, Ord, Typeable)
-
-instance Exception ArrayException
-
-stackOverflow, heapOverflow :: SomeException -- for the RTS
-stackOverflow = toException StackOverflow
-heapOverflow = toException HeapOverflow
-
-instance Show AsyncException where
- showsPrec _ StackOverflow = showString "stack overflow"
- showsPrec _ HeapOverflow = showString "heap overflow"
- showsPrec _ ThreadKilled = showString "thread killed"
- showsPrec _ UserInterrupt = showString "user interrupt"
-
-instance Show ArrayException where
- showsPrec _ (IndexOutOfBounds s)
- = showString "array index out of range"
- . (if not (null s) then showString ": " . showString s
- else id)
- showsPrec _ (UndefinedElement s)
- = showString "undefined array element"
- . (if not (null s) then showString ": " . showString s
- else id)
-
--- -----------------------------------------------------------------------------
--- The ExitCode type
-
--- We need it here because it is used in ExitException in the
--- Exception datatype (above).
-
-data ExitCode
- = ExitSuccess -- ^ indicates successful termination;
- | ExitFailure Int
- -- ^ indicates program failure with an exit code.
- -- The exact interpretation of the code is
- -- operating-system dependent. In particular, some values
- -- may be prohibited (e.g. 0 on a POSIX-compliant system).
- deriving (Eq, Ord, Read, Show, Typeable)
-
-instance Exception ExitCode
-
-ioException :: IOException -> IO a
-ioException err = throwIO err
-
--- | Raise an 'IOError' in the 'IO' monad.
-ioError :: IOError -> IO a
-ioError = ioException
-
--- ---------------------------------------------------------------------------
--- IOError type
-
--- | The Haskell 98 type for exceptions in the 'IO' monad.
--- Any I\/O operation may raise an 'IOError' instead of returning a result.
--- For a more general type of exception, including also those that arise
--- in pure code, see 'Control.Exception.Exception'.
---
--- In Haskell 98, this is an opaque type.
-type IOError = IOException
-
--- |Exceptions that occur in the @IO@ monad.
--- An @IOException@ records a more specific error type, a descriptive
--- string and maybe the handle that was used when the error was
--- flagged.
-data IOException
- = IOError {
- ioe_handle :: Maybe Handle, -- the handle used by the action flagging
- -- the error.
- ioe_type :: IOErrorType, -- what it was.
- ioe_location :: String, -- location.
- ioe_description :: String, -- error type specific information.
- ioe_errno :: Maybe CInt, -- errno leading to this error, if any.
- ioe_filename :: Maybe FilePath -- filename the error is related to.
- }
- deriving Typeable
-
-instance Exception IOException
-
-instance Eq IOException where
- (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) =
- e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2
-
--- | An abstract type that contains a value for each variant of 'IOError'.
-data IOErrorType
- -- Haskell 98:
- = AlreadyExists
- | NoSuchThing
- | ResourceBusy
- | ResourceExhausted
- | EOF
- | IllegalOperation
- | PermissionDenied
- | UserError
- -- GHC only:
- | UnsatisfiedConstraints
- | SystemError
- | ProtocolError
- | OtherError
- | InvalidArgument
- | InappropriateType
- | HardwareFault
- | UnsupportedOperation
- | TimeExpired
- | ResourceVanished
- | Interrupted
-
-instance Eq IOErrorType where
- x == y = getTag x ==# getTag y
-
-instance Show IOErrorType where
- showsPrec _ e =
- showString $
- case e of
- AlreadyExists -> "already exists"
- NoSuchThing -> "does not exist"
- ResourceBusy -> "resource busy"
- ResourceExhausted -> "resource exhausted"
- EOF -> "end of file"
- IllegalOperation -> "illegal operation"
- PermissionDenied -> "permission denied"
- UserError -> "user error"
- HardwareFault -> "hardware fault"
- InappropriateType -> "inappropriate type"
- Interrupted -> "interrupted"
- InvalidArgument -> "invalid argument"
- OtherError -> "failed"
- ProtocolError -> "protocol error"
- ResourceVanished -> "resource vanished"
- SystemError -> "system error"
- TimeExpired -> "timeout"
- UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
- UnsupportedOperation -> "unsupported operation"
-
--- | Construct an 'IOError' value with a string describing the error.
--- The 'fail' method of the 'IO' instance of the 'Monad' class raises a
--- 'userError', thus:
---
--- > instance Monad IO where
--- > ...
--- > fail s = ioError (userError s)
---
-userError :: String -> IOError
-userError str = IOError Nothing UserError "" str Nothing Nothing
-
--- ---------------------------------------------------------------------------
--- Showing IOErrors
-
-instance Show IOException where
- showsPrec p (IOError hdl iot loc s _ fn) =
- (case fn of
- Nothing -> case hdl of
- Nothing -> id
- Just h -> showsPrec p h . showString ": "
- Just name -> showString name . showString ": ") .
- (case loc of
- "" -> id
- _ -> showString loc . showString ": ") .
- showsPrec p iot .
- (case s of
- "" -> id
- _ -> showString " (" . showString s . showString ")")
-
--- -----------------------------------------------------------------------------
--- IOMode type
-
-data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Primitive catch and throwIO}
-%* *
-%*********************************************************
-
-catchException used to handle the passing around of the state to the
-action and the handler. This turned out to be a bad idea - it meant
-that we had to wrap both arguments in thunks so they could be entered
-as normal (remember IO returns an unboxed pair...).
-
-Now catch# has type
-
- catch# :: IO a -> (b -> IO a) -> IO a
-
-(well almost; the compiler doesn't know about the IO newtype so we
-have to work around that in the definition of catchException below).
-
-\begin{code}
-catchException :: Exception e => IO a -> (e -> IO a) -> IO a
-catchException (IO io) handler = IO $ catch# io handler'
- where handler' e = case fromException e of
- Just e' -> unIO (handler e')
- Nothing -> raise# e
-
-catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
-catchAny (IO io) handler = IO $ catch# io handler'
- where handler' (SomeException e) = unIO (handler e)
-
--- | A variant of 'throw' that can only be used within the 'IO' monad.
---
--- Although 'throwIO' has a type that is an instance of the type of 'throw', the
--- two functions are subtly different:
---
--- > throw e `seq` x ===> throw e
--- > throwIO e `seq` x ===> x
---
--- The first example will cause the exception @e@ to be raised,
--- whereas the second one won\'t. In fact, 'throwIO' will only cause
--- an exception to be raised when it is used within the 'IO' monad.
--- The 'throwIO' variant should be used in preference to 'throw' to
--- raise an exception within the 'IO' monad because it guarantees
--- ordering with respect to other 'IO' operations, whereas 'throw'
--- does not.
-throwIO :: Exception e => e -> IO a
-throwIO e = IO (raiseIO# (toException e))
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Controlling asynchronous exception delivery}
-%* *
-%*********************************************************
-
-\begin{code}
--- | Applying 'block' to a computation will
--- execute that computation with asynchronous exceptions
--- /blocked/. That is, any thread which
--- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be
--- blocked until asynchronous exceptions are enabled again. There\'s
--- no need to worry about re-enabling asynchronous exceptions; that is
--- done automatically on exiting the scope of
--- 'block'.
---
--- Threads created by 'Control.Concurrent.forkIO' inherit the blocked
--- state from the parent; that is, to start a thread in blocked mode,
--- use @block $ forkIO ...@. This is particularly useful if you need to
--- establish an exception handler in the forked thread before any
--- asynchronous exceptions are received.
-block :: IO a -> IO a
-
--- | To re-enable asynchronous exceptions inside the scope of
--- 'block', 'unblock' can be
--- used. It scopes in exactly the same way, so on exit from
--- 'unblock' asynchronous exception delivery will
--- be disabled again.
-unblock :: IO a -> IO a
-
-block (IO io) = IO $ blockAsyncExceptions# io
-unblock (IO io) = IO $ unblockAsyncExceptions# io
-
--- | returns True if asynchronous exceptions are blocked in the
--- current thread.
-blocked :: IO Bool
-blocked = IO $ \s -> case asyncExceptionsBlocked# s of
- (# s', i #) -> (# s', i /=# 0# #)
-\end{code}
-
-\begin{code}
--- | Forces its argument to be evaluated to weak head normal form when
--- the resultant 'IO' action is executed. It can be used to order
--- evaluation with respect to other 'IO' operations; its semantics are
--- given by
---
--- > evaluate x `seq` y ==> y
--- > evaluate x `catch` f ==> (return $! x) `catch` f
--- > evaluate x >>= f ==> (return $! x) >>= f
---
--- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the
--- same as @(return $! x)@. A correct definition is
---
--- > evaluate x = (return $! x) >>= return
---
-evaluate :: a -> IO a
-evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
- -- NB. can't write
- -- a `seq` (# s, a #)
- -- because we can't have an unboxed tuple as a function argument
-\end{code}
-
-\begin{code}
-assertError :: Addr# -> Bool -> a -> a
-assertError str predicate v
- | predicate = v
- | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
-
-{-
-(untangle coded message) expects "coded" to be of the form
- "location|details"
-It prints
- location message details
--}
-untangle :: Addr# -> String -> String
-untangle coded message
- = location
- ++ ": "
- ++ message
- ++ details
- ++ "\n"
- where
- coded_str = unpackCStringUtf8# coded
-
- (location, details)
- = case (span not_bar coded_str) of { (loc, rest) ->
- case rest of
- ('|':det) -> (loc, ' ' : det)
- _ -> (loc, "")
- }
- not_bar c = c /= '|'
-\end{code}
-
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IORef
+-- Copyright : (c) The University of Glasgow 2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- The IORef type
+--
+-----------------------------------------------------------------------------
+module GHC.IORef (
+ IORef(..),
+ newIORef, readIORef, writeIORef, atomicModifyIORef
+ ) where
+
+import GHC.Base
+import GHC.STRef
+import GHC.IO
+
+-- ---------------------------------------------------------------------------
+-- IORefs
+
+-- |A mutable variable in the 'IO' monad
+newtype IORef a = IORef (STRef RealWorld a)
+
+-- explicit instance because Haddock can't figure out a derived one
+instance Eq (IORef a) where
+ IORef x == IORef y = x == y
+
+-- |Build a new 'IORef'
+newIORef :: a -> IO (IORef a)
+newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
+
+-- |Read the value of an 'IORef'
+readIORef :: IORef a -> IO a
+readIORef (IORef var) = stToIO (readSTRef var)
+
+-- |Write a new value into an 'IORef'
+writeIORef :: IORef a -> a -> IO ()
+writeIORef (IORef var) v = stToIO (writeSTRef var v)
+
+atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
+atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
+
--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.MVar
+-- Copyright : (c) The University of Glasgow 2008
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- The MVar type
+--
+-----------------------------------------------------------------------------
+
+module GHC.MVar (
+ -- * MVars
+ MVar(..)
+ , newMVar -- :: a -> IO (MVar a)
+ , newEmptyMVar -- :: IO (MVar a)
+ , takeMVar -- :: MVar a -> IO a
+ , putMVar -- :: MVar a -> a -> IO ()
+ , tryTakeMVar -- :: MVar a -> IO (Maybe a)
+ , tryPutMVar -- :: MVar a -> a -> IO Bool
+ , isEmptyMVar -- :: MVar a -> IO Bool
+ , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+
+ ) where
+
+import GHC.Base
+import GHC.IO
+import Data.Maybe
+
+data MVar a = MVar (MVar# RealWorld a)
+{- ^
+An 'MVar' (pronounced \"em-var\") is a synchronising variable, used
+for communication between concurrent threads. It can be thought of
+as a a box, which may be empty or full.
+-}
+
+-- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module
+instance Eq (MVar a) where
+ (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
+
+{-
+M-Vars are rendezvous points for concurrent threads. They begin
+empty, and any attempt to read an empty M-Var blocks. When an M-Var
+is written, a single blocked thread may be freed. Reading an M-Var
+toggles its state from full back to empty. Therefore, any value
+written to an M-Var may only be read once. Multiple reads and writes
+are allowed, but there must be at least one read between any two
+writes.
+-}
+
+--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
+
+-- |Create an 'MVar' which is initially empty.
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = IO $ \ s# ->
+ case newMVar# s# of
+ (# s2#, svar# #) -> (# s2#, MVar svar# #)
+
+-- |Create an 'MVar' which contains the supplied value.
+newMVar :: a -> IO (MVar a)
+newMVar value =
+ newEmptyMVar >>= \ mvar ->
+ putMVar mvar value >>
+ return mvar
+
+-- |Return the contents of the 'MVar'. If the 'MVar' is currently
+-- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
+-- the 'MVar' is left empty.
+--
+-- There are two further important properties of 'takeMVar':
+--
+-- * 'takeMVar' is single-wakeup. That is, if there are multiple
+-- threads blocked in 'takeMVar', and the 'MVar' becomes full,
+-- only one thread will be woken up. The runtime guarantees that
+-- the woken thread completes its 'takeMVar' operation.
+--
+-- * When multiple threads are blocked on an 'MVar', they are
+-- woken up in FIFO order. This is useful for providing
+-- fairness properties of abstractions built using 'MVar's.
+--
+takeMVar :: MVar a -> IO a
+takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
+
+-- |Put a value into an 'MVar'. If the 'MVar' is currently full,
+-- 'putMVar' will wait until it becomes empty.
+--
+-- There are two further important properties of 'putMVar':
+--
+-- * 'putMVar' is single-wakeup. That is, if there are multiple
+-- threads blocked in 'putMVar', and the 'MVar' becomes empty,
+-- only one thread will be woken up. The runtime guarantees that
+-- the woken thread completes its 'putMVar' operation.
+--
+-- * When multiple threads are blocked on an 'MVar', they are
+-- woken up in FIFO order. This is useful for providing
+-- fairness properties of abstractions built using 'MVar's.
+--
+putMVar :: MVar a -> a -> IO ()
+putMVar (MVar mvar#) x = IO $ \ s# ->
+ case putMVar# mvar# x s# of
+ s2# -> (# s2#, () #)
+
+-- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
+-- returns immediately, with 'Nothing' if the 'MVar' was empty, or
+-- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
+-- the 'MVar' is left empty.
+tryTakeMVar :: MVar a -> IO (Maybe a)
+tryTakeMVar (MVar m) = IO $ \ s ->
+ case tryTakeMVar# m s of
+ (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty
+ (# s', _, a #) -> (# s', Just a #) -- MVar is full
+
+-- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
+-- attempts to put the value @a@ into the 'MVar', returning 'True' if
+-- it was successful, or 'False' otherwise.
+tryPutMVar :: MVar a -> a -> IO Bool
+tryPutMVar (MVar mvar#) x = IO $ \ s# ->
+ case tryPutMVar# mvar# x s# of
+ (# s, 0# #) -> (# s, False #)
+ (# s, _ #) -> (# s, True #)
+
+-- |Check whether a given 'MVar' is empty.
+--
+-- Notice that the boolean value returned is just a snapshot of
+-- the state of the MVar. By the time you get to react on its result,
+-- the MVar may have been filled (or emptied) - so be extremely
+-- careful when using this operation. Use 'tryTakeMVar' instead if possible.
+isEmptyMVar :: MVar a -> IO Bool
+isEmptyMVar (MVar mv#) = IO $ \ s# ->
+ case isEmptyMVar# mv# s# of
+ (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
+
+-- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
+-- "System.Mem.Weak" for more about finalizers.
+addMVarFinalizer :: MVar a -> IO () -> IO ()
+addMVarFinalizer (MVar m) finalizer =
+ IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }
+
import GHC.Ptr
import GHC.Base
-import GHC.IOBase
+import GHC.IO
-----------------------------------------------------------------------------
-- Stable Pointers
import GHC.Int
import GHC.Word
import GHC.Ptr
-import GHC.IOBase
+import GHC.IO
import GHC.Base
\end{code}
import GHC.Conc hiding (throwTo)
import GHC.Num
import GHC.Real
-import GHC.Handle
-import GHC.IOBase
+import GHC.MVar
+import GHC.IO
+import GHC.IO.Handle.FD
+import GHC.IO.Handle
+import GHC.IO.Exception
import GHC.Weak
import Data.Typeable
#if defined(mingw32_HOST_OS)
import GHC.Base
import Data.Maybe
-import GHC.IOBase ( IO(..), unIO )
+import GHC.IO ( IO(..), unIO )
import Data.Typeable
{-|
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
import Text.Read
import GHC.Enum
import GHC.Num
import Foreign.C
import Control.Exception.Base ( bracket )
import Control.Monad
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
#endif
#ifdef __HUGS__
import Prelude
#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
#endif
#ifdef __HUGS__
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.IOBase -- Together these four Prelude modules define
-import GHC.Handle -- all the stuff exported by IO for the GHC version
-import GHC.IO
+import GHC.IO hiding ( onException )
+import GHC.IO.IOMode
+import GHC.IO.Handle.FD
+import GHC.IO.Handle
+import GHC.IORef
+import GHC.IO.Exception ( userError )
import GHC.Exception
import GHC.Num
import Text.Read
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
+import GHC.IO.Handle.Types
import Text.Show
#endif
) where
#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase (unsafePerformIO, unsafeInterleaveIO)
+import GHC.IO (unsafePerformIO, unsafeInterleaveIO)
#endif
#ifdef __HUGS__
#endif
#ifdef __GLASGOW_HASKELL__
-import GHC.IOBase ( IO(..) )
+import GHC.IO ( IO(..) )
import GHC.Base ( Int(..), StableName#, makeStableName#
, eqStableName#, stableNameToInt# )
import GHC.Base
import GHC.Num
import GHC.Real
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.IOMode
+import GHC.IO.Exception
+import GHC.IO.Device
#elif __HUGS__
import Hugs.Prelude (IOException(..), IOErrorType(..))
import Hugs.IO (IOMode(..))
type CUtimbuf = ()
type CUtsname = ()
-#ifndef __GLASGOW_HASKELL__
type FD = CInt
-#endif
-- ---------------------------------------------------------------------------
-- stat()-related stuff
c_size <- st_size p_stat
return (fromIntegral c_size)
-data FDType = Directory | Stream | RegularFile | RawDevice
- deriving (Eq)
-
-fileType :: FilePath -> IO FDType
+fileType :: FilePath -> IO IODeviceType
fileType file =
allocaBytes sizeof_stat $ \ p_stat -> do
withCString file $ \p_file -> do
-- NOTE: On Win32 platforms, this will only work with file descriptors
-- referring to file handles. i.e., it'll fail for socket FDs.
-fdStat :: FD -> IO (FDType, CDev, CIno)
+fdStat :: FD -> IO (IODeviceType, CDev, CIno)
fdStat fd =
allocaBytes sizeof_stat $ \ p_stat -> do
throwErrnoIfMinus1Retry "fdType" $
ino <- st_ino p_stat
return (ty,dev,ino)
-fdType :: FD -> IO FDType
+fdType :: FD -> IO IODeviceType
fdType fd = do (ty,_,_) <- fdStat fd; return ty
-statGetType :: Ptr CStat -> IO FDType
+statGetType :: Ptr CStat -> IO IODeviceType
statGetType p_stat = do
c_mode <- st_mode p_stat :: IO CMode
case () of
ioe_unknownfiletype = UserError "fdType" "unknown file type"
#endif
-#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
-closeFd :: Bool -> CInt -> IO CInt
-closeFd isStream fd
- | isStream = c_closesocket fd
- | otherwise = c_close fd
-
-foreign import stdcall unsafe "HsBase.h closesocket"
- c_closesocket :: CInt -> IO CInt
-#endif
-
fdGetMode :: FD -> IO IOMode
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
fdGetMode _ = do
-- ---------------------------------------------------------------------------
-- Terminal-related stuff
-fdIsTTY :: FD -> IO Bool
-fdIsTTY fd = c_isatty fd >>= return.toBool
-
#if defined(HTYPE_TCFLAG_T)
setEcho :: FD -> Bool -> IO ()
#else
s_issock _ = False
#endif
+
+foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
GHC.Exts,
GHC.Float,
GHC.ForeignPtr,
- GHC.Handle,
+ GHC.MVar,
GHC.IO,
+ GHC.IO.IOMode,
+ GHC.IO.Buffer,
+ GHC.IO.Device,
+ GHC.IO.BufferedIO,
+ GHC.IO.FD,
+ GHC.IO.Exception,
+ GHC.IO.Encoding,
+ GHC.IO.Encoding.Latin1,
+ GHC.IO.Encoding.UTF8,
+ GHC.IO.Encoding.UTF16,
+ GHC.IO.Encoding.UTF32,
+ GHC.IO.Encoding.Types,
+ GHC.IO.Encoding.Iconv,
+ GHC.IO.Handle,
+ GHC.IO.Handle.Types,
+ GHC.IO.Handle.Internals,
+ GHC.IO.Handle.FD,
+ GHC.IO.Handle.Text,
GHC.IOBase,
+ GHC.Handle,
+ GHC.IORef,
+ GHC.IOArray,
GHC.Int,
GHC.List,
GHC.Num,
__hscore_memcpy_src_off( char *dst, char *src, int src_off, size_t sz )
{ return memcpy(dst, src+src_off, sz); }
-INLINE HsBool
-__hscore_supportsTextMode()
-{
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
- return HS_BOOL_FALSE;
-#else
- return HS_BOOL_TRUE;
-#endif
-}
-
INLINE HsInt
__hscore_bufsiz()
{
projects / ghc-base.git / commitdiff