Rewrite of the IO library, including Unicode support
authorSimon Marlow <marlowsd@gmail.com>
Fri, 12 Jun 2009 13:56:31 +0000 (13:56 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Fri, 12 Jun 2009 13:56:31 +0000 (13:56 +0000)
Highlights:

* Unicode support for Handle I/O:

  ** Automatic encoding and decoding using a per-Handle encoding.

  ** The encoding defaults to the locale encoding (only on Unix
     so far, perhaps Windows later).

  ** Built-in UTF-8, UTF-16 (BE/LE), and UTF-32 (BE/LE) codecs.

  ** iconv-based codec for other encodings on Unix

* Modularity: the low-level IO interface is exposed as a type class
  (GHC.IO.IODevice) so you can build your own low-level IO providers and
  make Handles from them.

* Newline translation: instead of being Windows-specific wired-in
  magic, the translation from \r\n -> \n and back again is available
  on all platforms and is configurable for reading/writing
  independently.

Unicode-aware Handles
~~~~~~~~~~~~~~~~~~~~~

This is a significant restructuring of the Handle implementation with
the primary goal of supporting Unicode character encodings.

The only change to the existing behaviour is that by default, text IO
is done in the prevailing locale encoding of the system (except on
Windows [1]).

Handles created by openBinaryFile use the Latin-1 encoding, as do
Handles placed in binary mode using hSetBinaryMode.

We provide a way to change the encoding for an existing Handle:

   GHC.IO.Handle.hSetEncoding :: Handle -> TextEncoding -> IO ()

and various encodings (from GHC.IO.Encoding):

   latin1,
   utf8,
   utf16, utf16le, utf16be,
   utf32, utf32le, utf32be,
   localeEncoding,

and a way to lookup other encodings:

   GHC.IO.Encoding.mkTextEncoding :: String -> IO TextEncoding

(it's system-dependent whether the requested encoding will be
available).

We may want to export these from somewhere more permanent; that's a
topic for a future library proposal.

Thanks to suggestions from Duncan Coutts, it's possible to call
hSetEncoding even on buffered read Handles, and the right thing
happens.  So we can read from text streams that include multiple
encodings, such as an HTTP response or email message, without having
to turn buffering off (though there is a penalty for switching
encodings on a buffered Handle, as the IO system has to do some
re-decoding to figure out where it should start reading from again).

If there is a decoding error, it is reported when an attempt is made
to read the offending character from the Handle, as you would expect.

Performance varies.  For "hGetContents >>= putStr" I found the new
library was faster on my x86_64 machine, but slower on an x86.  On the
whole I'd expect things to be a bit slower due to the extra
decoding/encoding, but probabaly not noticeably.  If performance is
critical for your app, then you should be using bytestring and text
anyway.

[1] Note: locale encoding is not currently implemented on Windows due
to the built-in Win32 APIs for encoding/decoding not being sufficient
for our purposes.  Ask me for details.  Offers of help gratefully
accepted.

Newline Translation
~~~~~~~~~~~~~~~~~~~

In the old IO library, text-mode Handles on Windows had automatic
translation from \r\n -> \n on input, and the opposite on output.  It
was implemented using the underlying CRT functions, which meant that
there were certain odd restrictions, such as read/write text handles
needing to be unbuffered, and seeking not working at all on text
Handles.

In the rewrite, newline translation is now implemented in the upper
layers, as it needs to be since we have to perform Unicode decoding
before newline translation.  This means that it is now available on
all platforms, which can be quite handy for writing portable code.

For now, I have left the behaviour as it was, namely \r\n -> \n on
Windows, and no translation on Unix.  However, another reasonable
default (similar to what Python does) would be to do \r\n -> \n on
input, and convert to the platform-native representation (either \r\n
or \n) on output.  This is called universalNewlineMode (below).

The API is as follows.  (available from GHC.IO.Handle for now, again
this is something we will probably want to try to get into System.IO
at some point):

-- | 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

-- | 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 a >>= writeFile b@ might yield a different file.
universalNewlineMode :: NewlineMode
universalNewlineMode  = NewlineMode { inputNL  = CRLF,
                                      outputNL = nativeNewline }

-- | Use the native newline representation on both input and output
nativeNewlineMode    :: NewlineMode
nativeNewlineMode     = NewlineMode { inputNL  = nativeNewline,
                                      outputNL = nativeNewline }

-- | Do no newline translation at all.
noNewlineTranslation :: NewlineMode
noNewlineTranslation  = NewlineMode { inputNL  = LF, outputNL = LF }

-- | Change the newline translation mode on the Handle.
hSetNewlineMode :: Handle -> NewlineMode -> IO ()

IO Devices
~~~~~~~~~~

The major change here is that the implementation of the Handle
operations is separated from the underlying IO device, using type
classes.  File descriptors are just one IO provider; I have also
implemented memory-mapped files (good for random-access read/write)
and a Handle that pipes output to a Chan (useful for testing code that
writes to a Handle).  New kinds of Handle can be implemented outside
the base package, for instance someone could write bytestringToHandle.
A Handle is made using mkFileHandle:

-- | 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
                     -- ^ text encoding to use, if any
              -> NewlineMode
                     -- ^ newline translation mode
              -> IO Handle

This also means that someone can write a completely new IO
implementation on Windows based on native Win32 HANDLEs, and
distribute it as a separate package (I really hope somebody does
this!).

This restructuring isn't as radical as previous designs.  I haven't
made any attempt to make a separate binary I/O layer, for example
(although hGetBuf/hPutBuf do bypass the text encoding and newline
translation).  The main goal here was to get Unicode support in, and
to allow others to experiment with making new kinds of Handle.  We
could split up the layers further later.

API changes and Module structure
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

NB. GHC.IOBase and GHC.Handle are now DEPRECATED (they are still
present, but are just re-exporting things from other modules now).
For 6.12 we'll want to bump base to version 5 and add a base4-compat.
For now I'm using #if __GLASGOW_HASKEL__ >= 611 to avoid deprecated
warnings.

I split modules into smaller parts in many places.  For example, we
now have GHC.IORef, GHC.MVar and GHC.IOArray containing the
implementations of IORef, MVar and IOArray respectively.  This was
necessary for untangling dependencies, but it also makes things easier
to follow.

The new module structurue for the IO-relatied parts of the base
package is:

GHC.IO
   Implementation of the IO monad; unsafe*; throw/catch

GHC.IO.IOMode
   The IOMode type

GHC.IO.Buffer
   Buffers and operations on them

GHC.IO.Device
   The IODevice and RawIO classes.

GHC.IO.BufferedIO
   The BufferedIO class.

GHC.IO.FD
   The FD type, with instances of IODevice, RawIO and BufferedIO.

GHC.IO.Exception
   IO-related Exceptions

GHC.IO.Encoding
   The TextEncoding type; built-in TextEncodings; mkTextEncoding

GHC.IO.Encoding.Types
GHC.IO.Encoding.Iconv
GHC.IO.Encoding.Latin1
GHC.IO.Encoding.UTF8
GHC.IO.Encoding.UTF16
GHC.IO.Encoding.UTF32
   Implementation internals for GHC.IO.Encoding

GHC.IO.Handle
   The main API for GHC's Handle implementation, provides all the Handle
   operations + mkFileHandle + hSetEncoding.

GHC.IO.Handle.Types
GHC.IO.Handle.Internals
GHC.IO.Handle.Text
   Implementation of Handles and operations.

GHC.IO.Handle.FD
   Parts of the Handle API implemented by file-descriptors: openFile,
   stdin, stdout, stderr, fdToHandle etc.

68 files changed:
Control/Concurrent.hs
Control/Concurrent/MVar.hs
Control/Exception.hs
Control/Exception/Base.hs
Control/Monad/ST.hs
Control/OldException.hs
Data/HashTable.hs
Data/IORef.hs
Data/Typeable.hs
Foreign/C/Error.hs
Foreign/C/String.hs
Foreign/C/Types.hs
Foreign/Concurrent.hs
Foreign/ForeignPtr.hs
Foreign/Marshal/Alloc.hs
Foreign/Marshal/Array.hs
Foreign/Marshal/Error.hs
Foreign/Marshal/Pool.hs
Foreign/Marshal/Utils.hs
Foreign/Ptr.hs
Foreign/Storable.hs
Foreign/Storable.hs-boot [deleted file]
GHC/Conc.lhs
GHC/ConsoleHandler.hs
GHC/ForeignPtr.hs
GHC/Handle.hs
GHC/Handle.hs-boot [deleted file]
GHC/IO.hs
GHC/IO/Buffer.hs [new file with mode: 0644]
GHC/IO/BufferedIO.hs [new file with mode: 0644]
GHC/IO/Device.hs [new file with mode: 0644]
GHC/IO/Encoding.hs [new file with mode: 0644]
GHC/IO/Encoding/Iconv.hs [new file with mode: 0644]
GHC/IO/Encoding/Latin1.hs [new file with mode: 0644]
GHC/IO/Encoding/Types.hs [new file with mode: 0644]
GHC/IO/Encoding/UTF16.hs [new file with mode: 0644]
GHC/IO/Encoding/UTF32.hs [new file with mode: 0644]
GHC/IO/Encoding/UTF8.hs [new file with mode: 0644]
GHC/IO/Exception.hs [new file with mode: 0644]
GHC/IO/Exception.hs-boot [new file with mode: 0644]
GHC/IO/FD.hs [new file with mode: 0644]
GHC/IO/Handle.hs [new file with mode: 0644]
GHC/IO/Handle.hs-boot [new file with mode: 0644]
GHC/IO/Handle/FD.hs [new file with mode: 0644]
GHC/IO/Handle/FD.hs-boot [new file with mode: 0644]
GHC/IO/Handle/Internals.hs [new file with mode: 0644]
GHC/IO/Handle/Text.hs [new file with mode: 0644]
GHC/IO/Handle/Types.hs [new file with mode: 0644]
GHC/IO/IOMode.hs [new file with mode: 0644]
GHC/IOArray.hs [new file with mode: 0644]
GHC/IOBase.hs [new file with mode: 0644]
GHC/IOBase.lhs [deleted file]
GHC/IORef.hs [new file with mode: 0644]
GHC/MVar.hs [new file with mode: 0644]
GHC/Stable.lhs
GHC/Storable.lhs
GHC/TopHandler.lhs
GHC/Weak.lhs
Prelude.hs
System/Environment.hs
System/Exit.hs
System/IO.hs
System/IO/Error.hs
System/IO/Unsafe.hs
System/Mem/StableName.hs
System/Posix/Internals.hs
base.cabal
include/HsBase.h

index e171285..2d9cf57 100644 (file)
@@ -100,9 +100,8 @@ import GHC.Exception
 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 )
@@ -113,7 +112,6 @@ import Control.Monad    ( when )
 #ifdef mingw32_HOST_OS
 import Foreign.C
 import System.IO
-import GHC.Handle
 #endif
 #endif
 
index 3513bbd..521b499 100644 (file)
@@ -40,7 +40,7 @@ import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
 #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
index 9e7a4c9..6430c9a 100644 (file)
@@ -138,7 +138,7 @@ import Control.Exception.Base
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
-import GHC.IOBase
+import GHC.IO hiding ( onException, finally )
 import Data.Maybe
 #else
 import Prelude hiding (catch)
index b803b5e..f32b2f7 100644 (file)
@@ -106,9 +106,10 @@ module Control.Exception.Base (
 
 #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
@@ -382,7 +383,7 @@ catch   :: Exception e
         -> (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
index b779664..cae255f 100644 (file)
@@ -57,7 +57,7 @@ unsafeInterleaveST =
 #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
index 7469908..ae25fdc 100644 (file)
@@ -134,13 +134,15 @@ module Control.OldException (
 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__
index 48ecb0b..c292a7c 100644 (file)
@@ -50,9 +50,9 @@ import GHC.Real         ( fromIntegral )
 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 )
index 70ea4b1..44e5de1 100644 (file)
@@ -35,7 +35,9 @@ import Hugs.IORef
 #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
@@ -75,7 +77,7 @@ modifyIORef ref f = readIORef ref >>= writeIORef ref . f
 --
 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
index 15dfa6a..c400710 100644 (file)
@@ -95,12 +95,14 @@ import GHC.Show         (Show(..), ShowS,
 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 )
@@ -488,7 +490,7 @@ INSTANCE_TYPEABLE2((->),funTc,"->")
 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
 
@@ -538,7 +540,9 @@ INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
 #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")
index 7c48180..ea38694 100644 (file)
@@ -108,7 +108,9 @@ import Foreign.Marshal.Error    ( void )
 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__
index e5c6c87..6d46a9e 100644 (file)
@@ -99,7 +99,7 @@ import Data.Word
 import GHC.List
 import GHC.Real
 import GHC.Num
-import GHC.IOBase
+import GHC.IO
 import GHC.Base
 #else
 import Data.Char ( chr, ord )
index 0304b15..44101fc 100644 (file)
@@ -69,7 +69,7 @@ module Foreign.C.Types
 
 #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 )
index 096f226..a09c06f 100644 (file)
@@ -28,7 +28,7 @@ module Foreign.Concurrent
   ) where
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.IOBase       ( IO )
+import GHC.IO           ( IO )
 import GHC.Ptr          ( Ptr )
 import GHC.ForeignPtr   ( ForeignPtr )
 import qualified GHC.ForeignPtr
index 59fcf82..9edd436 100644 (file)
@@ -78,7 +78,7 @@ import Foreign.Storable ( Storable(sizeOf) )
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
-import GHC.IOBase
+import GHC.IO
 import GHC.Num
 import GHC.Err          ( undefined )
 import GHC.ForeignPtr
index 19cce12..574e6a4 100644 (file)
@@ -40,7 +40,8 @@ import Foreign.Ptr              ( Ptr, nullPtr, FunPtr )
 
 #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
index 2297a4d..bac13cd 100644 (file)
@@ -68,7 +68,7 @@ import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes)
 import Foreign.Marshal.Utils (copyBytes, moveBytes)
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.IOBase
+import GHC.IO
 import GHC.Num
 import GHC.List
 import GHC.Err
index 3d72956..5bc2f34 100644 (file)
@@ -37,7 +37,8 @@ import System.IO.Error
 #endif
 import GHC.Base
 import GHC.Num
-import GHC.IOBase
+import GHC.IO
+import GHC.IO.Exception
 #endif
 
 -- exported functions
index 540c164..9c07558 100644 (file)
@@ -48,8 +48,8 @@ module Foreign.Marshal.Pool (
 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
index 4aa0e74..85d802e 100644 (file)
@@ -53,7 +53,7 @@ import Foreign.C.Types          ( CSize )
 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
index 7c83326..f6fac7d 100644 (file)
@@ -50,7 +50,7 @@ module Foreign.Ptr (
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Ptr
-import GHC.IOBase
+import GHC.IO
 import GHC.Base
 import GHC.Num
 import GHC.Read
index dfcafa6..65b4193 100644 (file)
@@ -47,7 +47,7 @@ import GHC.Int
 import GHC.Word
 import GHC.Ptr
 import GHC.Err
-import GHC.IOBase
+import GHC.IO
 import GHC.Base
 #else
 import Data.Int
diff --git a/Foreign/Storable.hs-boot b/Foreign/Storable.hs-boot
deleted file mode 100644 (file)
index c83715b..0000000
+++ /dev/null
@@ -1,22 +0,0 @@
-
-{-# 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
-
index b53bf54..2d62308 100644 (file)
@@ -50,17 +50,6 @@ module GHC.Conc
         , 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
@@ -78,6 +67,7 @@ module GHC.Conc
         , 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)
@@ -121,11 +111,17 @@ import Control.Monad
 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
@@ -136,10 +132,8 @@ import GHC.Ptr          ( plusPtr, FunPtr(..) )
 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
@@ -599,111 +593,19 @@ writeTVar (TVar tvar#) val = STM $ \s1# ->
   
 \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}
@@ -898,10 +800,6 @@ delayTime (DelaySTM t _) = t
 
 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
 
@@ -1408,14 +1306,4 @@ setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
 
 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}
index 7587d94..af115b8 100644 (file)
@@ -34,10 +34,13 @@ import Prelude -- necessary to get dependencies right
 
 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
@@ -134,19 +137,16 @@ foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
 
 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 */
index 25dc0fa..f3601ba 100644 (file)
@@ -42,7 +42,8 @@ import Data.Typeable
 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
index c962edc..5d231ea 100644 (file)
@@ -1,11 +1,4 @@
-{-# 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,
@@ -53,1791 +47,9 @@ module GHC.Handle (
 
   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
diff --git a/GHC/Handle.hs-boot b/GHC/Handle.hs-boot
deleted file mode 100644 (file)
index 7ace1d8..0000000
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
-
-module GHC.Handle where
-
-import GHC.IOBase
-
-stdout :: Handle
-stderr :: Handle
-hFlush :: Handle -> IO ()
index 231244b..fef57da 100644 (file)
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
-{-# 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
diff --git a/GHC/IO/Buffer.hs b/GHC/IO/Buffer.hs
new file mode 100644 (file)
index 0000000..bcdaabd
--- /dev/null
@@ -0,0 +1,278 @@
+{-# 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)
diff --git a/GHC/IO/BufferedIO.hs b/GHC/IO/BufferedIO.hs
new file mode 100644 (file)
index 0000000..a70b1d9
--- /dev/null
@@ -0,0 +1,115 @@
+{-# 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 })
+
diff --git a/GHC/IO/Device.hs b/GHC/IO/Device.hs
new file mode 100644 (file)
index 0000000..ab91bc0
--- /dev/null
@@ -0,0 +1,145 @@
+{-# 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)
diff --git a/GHC/IO/Encoding.hs b/GHC/IO/Encoding.hs
new file mode 100644 (file)
index 0000000..cf1584e
--- /dev/null
@@ -0,0 +1,107 @@
+{-# 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
diff --git a/GHC/IO/Encoding/Iconv.hs b/GHC/IO/Encoding/Iconv.hs
new file mode 100644 (file)
index 0000000..cca3ebc
--- /dev/null
@@ -0,0 +1,212 @@
+{-# 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 */
diff --git a/GHC/IO/Encoding/Latin1.hs b/GHC/IO/Encoding/Latin1.hs
new file mode 100644 (file)
index 0000000..60598f6
--- /dev/null
@@ -0,0 +1,118 @@
+{-# 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)
diff --git a/GHC/IO/Encoding/Types.hs b/GHC/IO/Encoding/Types.hs
new file mode 100644 (file)
index 0000000..b857bdf
--- /dev/null
@@ -0,0 +1,72 @@
+{-# 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
+  }
diff --git a/GHC/IO/Encoding/UTF16.hs b/GHC/IO/Encoding/UTF16.hs
new file mode 100644 (file)
index 0000000..e3801c0
--- /dev/null
@@ -0,0 +1,310 @@
+{-# 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 #-}
diff --git a/GHC/IO/Encoding/UTF32.hs b/GHC/IO/Encoding/UTF32.hs
new file mode 100644 (file)
index 0000000..b26aaae
--- /dev/null
@@ -0,0 +1,273 @@
+{-# 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 #-}
diff --git a/GHC/IO/Encoding/UTF8.hs b/GHC/IO/Encoding/UTF8.hs
new file mode 100644 (file)
index 0000000..43adff1
--- /dev/null
@@ -0,0 +1,242 @@
+{-# 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
diff --git a/GHC/IO/Exception.hs b/GHC/IO/Exception.hs
new file mode 100644 (file)
index 0000000..232ed83
--- /dev/null
@@ -0,0 +1,336 @@
+{-# 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 /= '|'
diff --git a/GHC/IO/Exception.hs-boot b/GHC/IO/Exception.hs-boot
new file mode 100644 (file)
index 0000000..f1ba724
--- /dev/null
@@ -0,0 +1,12 @@
+{-# 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
diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
new file mode 100644 (file)
index 0000000..7ceffc3
--- /dev/null
@@ -0,0 +1,630 @@
+{-# 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
diff --git a/GHC/IO/Handle.hs b/GHC/IO/Handle.hs
new file mode 100644 (file)
index 0000000..b4b90e8
--- /dev/null
@@ -0,0 +1,686 @@
+{-# 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
diff --git a/GHC/IO/Handle.hs-boot b/GHC/IO/Handle.hs-boot
new file mode 100644 (file)
index 0000000..68379e2
--- /dev/null
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+module GHC.IO.Handle where
+
+import GHC.IO
+import GHC.IO.Handle.Types
+
+hFlush :: Handle -> IO ()
diff --git a/GHC/IO/Handle/FD.hs b/GHC/IO/Handle/FD.hs
new file mode 100644 (file)
index 0000000..d74dd2d
--- /dev/null
@@ -0,0 +1,250 @@
+{-# 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
diff --git a/GHC/IO/Handle/FD.hs-boot b/GHC/IO/Handle/FD.hs-boot
new file mode 100644 (file)
index 0000000..657af38
--- /dev/null
@@ -0,0 +1,7 @@
+{-# 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
diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs
new file mode 100644 (file)
index 0000000..1826696
--- /dev/null
@@ -0,0 +1,793 @@
+{-# 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'
diff --git a/GHC/IO/Handle/Text.hs b/GHC/IO/Handle/Text.hs
new file mode 100644 (file)
index 0000000..2dd86df
--- /dev/null
@@ -0,0 +1,961 @@
+{-# 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)))
+ &