{-# LANGUAGE Safe #-}

{- arch-tag: HVIO main file
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : System.IO.HVIO
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable

Haskell Virtual I\/O -- a system to increase the flexibility of input and
output in Haskell

Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org

HVIO provides the following general features:

 * The ability to use a single set of functions on various different
   types of objects, including standard Handles, in-memory buffers,
   compressed files, network data streams, etc.

 * The ability to transparently add filters to the I\/O process.
   These filters could include things such as character set conversions,
   compression or decompression of a data stream, and more.

 * The ability to define new objects that have the properties
   of I\/O objects and can be used interchangably with them.

 * Specification compatibility with, and complete support for,
   existing I\/O on Handles.

 * Provide easier unit testing capabilities for I\/O actions

HVIO defines several basic type classes that you can use.  You will mostly
be interested in 'HVIO'.

It's trivial to adapt old code to work with HVIO.  For instance, consider
this example of old and new code:

>printMsg :: Handle -> String -> IO ()
>printMsg h msg = hPutStr h ("msg: " ++ msg)

And now, the new way:

>printMsg :: HVIO h => h -> String -> IO ()
>printMsg h msg = vPutStr h ("msg: " ++ msg)

There are several points to note about this conversion:

 * The new method can still accept a Handle in exactly the same way as
   the old method.  Changing your functions to use HVIO will require no
   changes from functions that call them with Handles.

 * Most \"h\" functions have equivolent \"v\" functions that operate
   on HVIO classes instead of the more specific Handle.  The \"v\" functions
   behave identically to the \"h\" functions whenever possible.

 * There is no equivolent of \"openFile\" in any HVIO class.  You must
   create your Handle (or other HVIO object) using normal means.
   This is because the creation is so different that it cannot be standardized.

In addition to Handle, there are several pre-defined classes for your use.
'StreamReader' is a particularly interesting one.  At creation time, you pass
it a String.  Its contents are read lazily whenever a read call is made.  It
can be used, therefore, to implement filters (simply initialize it with the
result from, say, a map over hGetContents from another HVIO object), codecs,
and simple I\/O testing.  Because it is lazy, it need not hold the entire
string in memory.  You can create a 'StreamReader' with a call to
'newStreamReader'.

'MemoryBuffer' is a similar class, but with a different purpose.  It provides
a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter',
and 'HVIOSeeker').  However, it maintains an in-memory buffer with the
contents of the file, rather than an actual on-disk file.  You can access
the entire contents of this buffer at any time.  This can be quite useful
for testing I\/O code, or for cases where existing APIs use I\/O, but you
prefer a String representation.  You can create a 'MemoryBuffer' with a call
to 'newMemoryBuffer'.

Finally, there are pipes.  These pipes are analogous to the Unix
pipes that are available from System.Posix, but don't require Unix and work
only in Haskell.  When you create a pipe, you actually get two HVIO objects:
a 'PipeReader' and a 'PipeWriter'.  You must use the 'PipeWriter' in one
thread and the 'PipeReader' in another thread.  Data that's written to the
'PipeWriter' will then be available for reading with the 'PipeReader'.  The
pipes are implemented completely with existing Haskell threading primitives,
and require no special operating system support.  Unlike Unix pipes, these
pipes cannot be used across a fork().  Also unlike Unix pipes, these pipes
are portable and interact well with Haskell threads.  A new pipe can be created
with a call to 'newHVIOPipe'.

Together with "System.IO.HVFS", this module is part of a complete
virtual filesystem solution.
-}

module System.IO.HVIO(-- * Implementation Classes
                     HVIO(..),
                     -- * Standard HVIO Implementations

                     -- ** Handle
                     -- | Handle is a member of 'HVIO'.

                     -- ** Stream Reader
                     StreamReader, newStreamReader,

                     -- ** Memory Buffer
                     MemoryBuffer, newMemoryBuffer,
                     mbDefaultCloseFunc, getMemoryBuffer,

                     -- ** Haskell Pipe
                     PipeReader, PipeWriter, newHVIOPipe
                    )
where

import safe Control.Concurrent.MVar
    ( newEmptyMVar, putMVar, readMVar, takeMVar, MVar )
import qualified Control.Exception       (catch)
import safe Data.IORef ( IORef, modifyIORef, newIORef, readIORef )
import safe Foreign.C ( castCharToCChar, peekCStringLen )
import safe Foreign.Ptr ( Ptr, castPtr, plusPtr )
import safe Foreign.Storable ( Storable(poke) )
import safe System.IO
    ( Handle,
      hClose,
      hFlush,
      hGetBuffering,
      hIsClosed,
      hIsEOF,
      hIsOpen,
      hIsReadable,
      hIsSeekable,
      hIsWritable,
      hSeek,
      hSetBuffering,
      hShow,
      hTell,
      hGetBuf,
      hGetChar,
      hGetContents,
      hGetLine,
      hPutBuf,
      hPutChar,
      hPutStr,
      hPutStrLn,
      hPrint,
      hReady,
      SeekMode(..),
      BufferMode(NoBuffering) )
import safe System.IO.Error
    ( IOErrorType,
      eofErrorType,
      illegalOperationErrorType,
      isEOFError,
      mkIOError )

{- | This is the generic I\/O support class.  All objects that are to be used
in the HVIO system must provide an instance of 'HVIO'.

Functions in this class provide an interface with the same specification as
the similar functions in System.IO.  Please refer to that documentation
for a more complete specification than is provided here.

Instances of 'HVIO' must provide 'vClose', 'vIsEOF', and either
'vIsOpen' or 'vIsClosed'.

Implementators of readable objects must provide at least 'vGetChar'
and 'vIsReadable'.
An implementation of 'vGetContents' is also highly suggested, since
the default cannot implement proper partial closing semantics.

Implementators of writable objects must provide at least 'vPutChar' and
'vIsWritable'.

Implementators of seekable objects must provide at least
'vIsSeekable', 'vTell', and 'vSeek'.
-}
class (Show a) => HVIO a where
    -- | Close a file
    vClose :: a -> IO ()
    -- | Test if a file is open
    vIsOpen :: a -> IO Bool
    -- | Test if a file is closed
    vIsClosed :: a -> IO Bool
    -- | Raise an error if the file is not open.
    -- This is a new HVIO function and is implemented in terms of
    -- 'vIsOpen'.
    vTestOpen :: a -> IO ()
    -- | Whether or not we're at EOF.  This may raise on exception
    -- on some items, most notably write-only Handles such as stdout.
    -- In general, this is most reliable on items opened for reading.
    -- vIsEOF implementations must implicitly call vTestOpen.
    vIsEOF :: a -> IO Bool
    -- | Detailed show output.
    vShow :: a -> IO String
    -- | Make an IOError.
    vMkIOError :: a -> IOErrorType -> String -> Maybe FilePath -> IOError
    -- | Throw an IOError.
    vThrow :: a -> IOErrorType -> IO b
    -- | Get the filename\/object\/whatever that this corresponds to.
    -- May be Nothing.
    vGetFP :: a -> IO (Maybe FilePath)
    -- | Throw an isEOFError if we're at EOF; returns nothing otherwise.
    -- If an implementation overrides the default, make sure that it
    -- calls vTestOpen at some point.  The default implementation is
    -- a wrapper around a call to 'vIsEOF'.
    vTestEOF :: a -> IO ()

    -- | Read one character
    vGetChar :: a -> IO Char
    -- | Read one line
    vGetLine :: a -> IO String
    {- | Get the remaining contents.  Please note that as a user of this
       function, the same partial-closing semantics as are used in the
       standard 'hGetContents' are /encouraged/ from implementators,
       but are not /required/.  That means that, for instance,
       a 'vGetChar' after a 'vGetContents' may return some undefined
       result instead of the error you would normally get.  You should
       use caution to make sure your code doesn't fall into that trap,
       or make sure to test your code with Handle or one of the
       default instances defined in this module.  Also, some implementations
       may essentially provide a complete close after a call to 'vGetContents'.
       The bottom line: after a call to 'vGetContents', you should do nothing
       else with the object save closing it with 'vClose'.

       For implementators, you are highly encouraged to provide a correct
       implementation. -}
    vGetContents :: a -> IO String
    -- | Indicate whether at least one item is ready for reading.
    -- This will always be True for a great many implementations.
    vReady :: a -> IO Bool
    -- | Indicate whether a particular item is available for reading.
    vIsReadable :: a -> IO Bool

    -- | Write one character
    vPutChar :: a -> Char -> IO ()
    -- | Write a string
    vPutStr :: a -> String -> IO ()
    -- | Write a string with newline character after it
    vPutStrLn :: a -> String -> IO ()
    -- | Write a string representation of the argument, plus a newline.
    vPrint :: Show b => a -> b -> IO ()
    -- | Flush any output buffers.
    -- Note: implementations should assure that a vFlush is automatically
    -- performed
    -- on file close, if necessary to ensure all data sent is written.
    vFlush :: a -> IO ()
    -- | Indicate whether or not this particular object supports writing.
    vIsWritable :: a -> IO Bool

    -- | Seek to a specific location.
    vSeek :: a -> SeekMode -> Integer -> IO ()

    -- | Get the current position.
    vTell :: a -> IO Integer

    -- | Convenience function to reset the file pointer to the beginning
    -- of the file.  A call to @vRewind h@ is the
    -- same as @'vSeek' h AbsoluteSeek 0@.
    vRewind :: a -> IO ()

    -- | Indicate whether this instance supports seeking.
    vIsSeekable :: a -> IO Bool

    -- | Set buffering; the default action is a no-op.
    vSetBuffering :: a -> BufferMode -> IO ()

    -- | Get buffering; the default action always returns NoBuffering.
    vGetBuffering :: a -> IO BufferMode

    -- | Binary output: write the specified number of octets from the specified
    -- buffer location.
    vPutBuf :: a -> Ptr b -> Int -> IO ()

    -- | Binary input: read the specified number of octets from the
    -- specified buffer location, continuing to read
    -- until it either consumes that much data or EOF is encountered.
    -- Returns the number of octets actually read.  EOF errors are never
    -- raised; fewer bytes than requested are returned on EOF.
    vGetBuf :: a -> Ptr b -> Int -> IO Int

    vSetBuffering a
_ BufferMode
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    vGetBuffering a
_ = BufferMode -> IO BufferMode
forall (m :: * -> *) a. Monad m => a -> m a
return BufferMode
NoBuffering

    vShow a
x = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> String
forall a. Show a => a -> String
show a
x)

    vMkIOError a
_ IOErrorType
et String
desc Maybe String
mfp =
        IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
et String
desc Maybe Handle
forall a. Maybe a
Nothing Maybe String
mfp

    vGetFP a
_ = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

    vThrow a
h IOErrorType
et = do
                  Maybe String
fp <- a -> IO (Maybe String)
forall a. HVIO a => a -> IO (Maybe String)
vGetFP a
h
                  IOError -> IO b
forall a. IOError -> IO a
ioError (a -> IOErrorType -> String -> Maybe String -> IOError
forall a.
HVIO a =>
a -> IOErrorType -> String -> Maybe String -> IOError
vMkIOError a
h IOErrorType
et String
"" Maybe String
fp)

    vTestEOF a
h = do Bool
e <- a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsEOF a
h
                    if Bool
e then a -> IOErrorType -> IO ()
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
eofErrorType
                       else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    vIsOpen a
h = a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsClosed a
h IO Bool -> (Bool -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (Bool -> Bool) -> Bool -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not
    vIsClosed a
h = a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsOpen a
h IO Bool -> (Bool -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (Bool -> Bool) -> Bool -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not
    vTestOpen a
h = do Bool
e <- a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsClosed a
h
                     if Bool
e then a -> IOErrorType -> IO ()
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
                        else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


    vIsReadable a
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    vGetLine a
h =
        let loop :: String -> IO String
loop String
accum =
                let func :: IO String
func = do Char
c <- a -> IO Char
forall a. HVIO a => a -> IO Char
vGetChar a
h
                              case Char
c of
                                     Char
'\n' -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
accum
                                     Char
x    -> String
accum String -> IO String -> IO String
`seq` String -> IO String
loop (String
accum String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
x])
                    handler :: IOError -> IO String
handler IOError
e = if IOError -> Bool
isEOFError IOError
e then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
accum
                                else IOError -> IO String
forall a. IOError -> IO a
ioError IOError
e
                    in IO String -> (IOError -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO String
func IOError -> IO String
handler
            in
            do Char
firstchar <- a -> IO Char
forall a. HVIO a => a -> IO Char
vGetChar a
h
               case Char
firstchar of
                   Char
'\n' -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return []
                   Char
x    -> String -> IO String
loop [Char
x]

    vGetContents a
h =
        let loop :: IO String
loop =
                let func :: IO String
func = do Char
c <- a -> IO Char
forall a. HVIO a => a -> IO Char
vGetChar a
h
                              String
next <- IO String
loop
                              Char
c Char -> IO String -> IO String
`seq` String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
next)
                    handler :: IOError -> IO [a]
handler IOError
e = if IOError -> Bool
isEOFError IOError
e then [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                                else IOError -> IO [a]
forall a. IOError -> IO a
ioError IOError
e
                    in IO String -> (IOError -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO String
func IOError -> IO String
forall {a}. IOError -> IO [a]
handler
            in
            do IO String
loop

    vReady a
h = do a -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF a
h
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


    vIsWritable a
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    vPutStr a
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    vPutStr a
h (Char
x:String
xs) = do a -> Char -> IO ()
forall a. HVIO a => a -> Char -> IO ()
vPutChar a
h Char
x
                          a -> String -> IO ()
forall a. HVIO a => a -> String -> IO ()
vPutStr a
h String
xs

    vPutStrLn a
h String
s = a -> String -> IO ()
forall a. HVIO a => a -> String -> IO ()
vPutStr a
h (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")

    vPrint a
h b
s = a -> String -> IO ()
forall a. HVIO a => a -> String -> IO ()
vPutStrLn a
h (b -> String
forall a. Show a => a -> String
show b
s)

    vFlush = a -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen


    vIsSeekable a
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    vRewind a
h = a -> SeekMode -> Integer -> IO ()
forall a. HVIO a => a -> SeekMode -> Integer -> IO ()
vSeek a
h SeekMode
AbsoluteSeek Integer
0

    vPutChar a
h Char
_ = a -> IOErrorType -> IO ()
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
    vSeek a
h SeekMode
_ Integer
_ = a -> IOErrorType -> IO ()
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
    vTell a
h = a -> IOErrorType -> IO Integer
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
    vGetChar a
h = a -> IOErrorType -> IO Char
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType


    vPutBuf a
h Ptr b
buf Int
len =
        do String
str <- CStringLen -> IO String
peekCStringLen (Ptr b -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr b
buf, Int
len)
           a -> String -> IO ()
forall a. HVIO a => a -> String -> IO ()
vPutStr a
h String
str

    vGetBuf a
h Ptr b
b Int
l =
        Ptr b -> Int -> Int -> IO Int
forall {t} {t} {b}. (Eq t, Num t, Num t) => Ptr b -> t -> t -> IO t
worker Ptr b
b Int
l Int
0
        where worker :: Ptr b -> t -> t -> IO t
worker Ptr b
_ t
0 t
accum = t -> IO t
forall (m :: * -> *) a. Monad m => a -> m a
return t
accum
              worker Ptr b
buf t
len t
accum =
                  do Bool
iseof <- a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsEOF a
h
                     if Bool
iseof
                        then t -> IO t
forall (m :: * -> *) a. Monad m => a -> m a
return t
accum
                        else do Char
c <- a -> IO Char
forall a. HVIO a => a -> IO Char
vGetChar a
h
                                let cc :: CChar
cc = Char -> CChar
castCharToCChar Char
c
                                Ptr CChar -> CChar -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr b -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr b
buf) CChar
cc
                                let newptr :: Ptr b
newptr = Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr b
buf Int
1
                                Ptr b -> t -> t -> IO t
worker Ptr b
forall {b}. Ptr b
newptr (t
len t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (t
accum t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

----------------------------------------------------------------------
-- Handle instances
----------------------------------------------------------------------
instance HVIO Handle where
    vClose :: Handle -> IO ()
vClose = Handle -> IO ()
hClose
    vIsEOF :: Handle -> IO Bool
vIsEOF = Handle -> IO Bool
hIsEOF
    vShow :: Handle -> IO String
vShow = Handle -> IO String
hShow
    vMkIOError :: Handle -> IOErrorType -> String -> Maybe String -> IOError
vMkIOError Handle
h IOErrorType
et String
desc Maybe String
mfp =
        IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
et String
desc (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h) Maybe String
mfp
    vGetChar :: Handle -> IO Char
vGetChar = Handle -> IO Char
hGetChar
    vGetLine :: Handle -> IO String
vGetLine = Handle -> IO String
hGetLine
    vGetContents :: Handle -> IO String
vGetContents = Handle -> IO String
hGetContents
    vReady :: Handle -> IO Bool
vReady = Handle -> IO Bool
hReady
    vIsReadable :: Handle -> IO Bool
vIsReadable = Handle -> IO Bool
hIsReadable
    vPutChar :: Handle -> Char -> IO ()
vPutChar = Handle -> Char -> IO ()
hPutChar
    vPutStr :: Handle -> String -> IO ()
vPutStr = Handle -> String -> IO ()
hPutStr
    vPutStrLn :: Handle -> String -> IO ()
vPutStrLn = Handle -> String -> IO ()
hPutStrLn
    vPrint :: forall b. Show b => Handle -> b -> IO ()
vPrint = Handle -> b -> IO ()
forall b. Show b => Handle -> b -> IO ()
hPrint
    vFlush :: Handle -> IO ()
vFlush = Handle -> IO ()
hFlush
    vIsWritable :: Handle -> IO Bool
vIsWritable = Handle -> IO Bool
hIsWritable
    vSeek :: Handle -> SeekMode -> Integer -> IO ()
vSeek = Handle -> SeekMode -> Integer -> IO ()
hSeek
    vTell :: Handle -> IO Integer
vTell = Handle -> IO Integer
hTell
    vIsSeekable :: Handle -> IO Bool
vIsSeekable = Handle -> IO Bool
hIsSeekable
    vSetBuffering :: Handle -> BufferMode -> IO ()
vSetBuffering = Handle -> BufferMode -> IO ()
hSetBuffering
    vGetBuffering :: Handle -> IO BufferMode
vGetBuffering = Handle -> IO BufferMode
hGetBuffering
    vGetBuf :: forall b. Handle -> Ptr b -> Int -> IO Int
vGetBuf = Handle -> Ptr b -> Int -> IO Int
forall b. Handle -> Ptr b -> Int -> IO Int
hGetBuf
    vPutBuf :: forall b. Handle -> Ptr b -> Int -> IO ()
vPutBuf = Handle -> Ptr b -> Int -> IO ()
forall b. Handle -> Ptr b -> Int -> IO ()
hPutBuf
    vIsOpen :: Handle -> IO Bool
vIsOpen = Handle -> IO Bool
hIsOpen
    vIsClosed :: Handle -> IO Bool
vIsClosed = Handle -> IO Bool
hIsClosed

----------------------------------------------------------------------
-- VIO Support
----------------------------------------------------------------------
type VIOCloseSupport a = IORef (Bool, a)

vioc_isopen :: VIOCloseSupport a -> IO Bool
vioc_isopen :: forall a. VIOCloseSupport a -> IO Bool
vioc_isopen VIOCloseSupport a
x = VIOCloseSupport a -> IO (Bool, a)
forall a. IORef a -> IO a
readIORef VIOCloseSupport a
x IO (Bool, a) -> ((Bool, a) -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> ((Bool, a) -> Bool) -> (Bool, a) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, a) -> Bool
forall a b. (a, b) -> a
fst

vioc_get :: VIOCloseSupport a -> IO a
vioc_get :: forall a. VIOCloseSupport a -> IO a
vioc_get VIOCloseSupport a
x = VIOCloseSupport a -> IO (Bool, a)
forall a. IORef a -> IO a
readIORef VIOCloseSupport a
x IO (Bool, a) -> ((Bool, a) -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> ((Bool, a) -> a) -> (Bool, a) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, a) -> a
forall a b. (a, b) -> b
snd

vioc_close :: VIOCloseSupport a -> IO ()
vioc_close :: forall a. VIOCloseSupport a -> IO ()
vioc_close VIOCloseSupport a
x = VIOCloseSupport a -> ((Bool, a) -> (Bool, a)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef VIOCloseSupport a
x (\ (Bool
_, a
dat) -> (Bool
False, a
dat))

vioc_set :: VIOCloseSupport a -> a -> IO ()
vioc_set :: forall a. VIOCloseSupport a -> a -> IO ()
vioc_set VIOCloseSupport a
x a
newdat = VIOCloseSupport a -> ((Bool, a) -> (Bool, a)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef VIOCloseSupport a
x (\ (Bool
stat, a
_) -> (Bool
stat, a
newdat))

----------------------------------------------------------------------
-- Stream Readers
----------------------------------------------------------------------
{- | Simulate I\/O based on a string buffer.

When a 'StreamReader' is created, it is initialized based on the contents of
a 'String'.  Its contents are read lazily whenever a request is made to read
something from the 'StreamReader'.    It
can be used, therefore, to implement filters (simply initialize it with the
result from, say, a map over hGetContents from another HVIO object), codecs,
and simple I\/O testing.  Because it is lazy, it need not hold the entire
string in memory.  You can create a 'StreamReader' with a call to
'newStreamReader'.
 -}
newtype StreamReader = StreamReader (VIOCloseSupport String)

{- | Create a new 'StreamReader' object. -}
newStreamReader :: String            -- ^ Initial contents of the 'StreamReader'
                -> IO StreamReader
newStreamReader :: String -> IO StreamReader
newStreamReader String
s = do IORef (Bool, String)
ref <- (Bool, String) -> IO (IORef (Bool, String))
forall a. a -> IO (IORef a)
newIORef (Bool
True, String
s)
                       StreamReader -> IO StreamReader
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef (Bool, String) -> StreamReader
StreamReader IORef (Bool, String)
ref)

srv :: StreamReader -> VIOCloseSupport String
srv :: StreamReader -> IORef (Bool, String)
srv (StreamReader IORef (Bool, String)
x) = IORef (Bool, String)
x

instance Show StreamReader where
    show :: StreamReader -> String
show StreamReader
_ = String
"<StreamReader>"

instance HVIO StreamReader where
    vClose :: StreamReader -> IO ()
vClose = IORef (Bool, String) -> IO ()
forall a. VIOCloseSupport a -> IO ()
vioc_close (IORef (Bool, String) -> IO ())
-> (StreamReader -> IORef (Bool, String)) -> StreamReader -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamReader -> IORef (Bool, String)
srv
    vIsEOF :: StreamReader -> IO Bool
vIsEOF StreamReader
h = do StreamReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen StreamReader
h
                  String
d <- IORef (Bool, String) -> IO String
forall a. VIOCloseSupport a -> IO a
vioc_get (StreamReader -> IORef (Bool, String)
srv StreamReader
h)
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case String
d of
                                  [] -> Bool
True
                                  String
_  -> Bool
False
    vIsOpen :: StreamReader -> IO Bool
vIsOpen = IORef (Bool, String) -> IO Bool
forall a. VIOCloseSupport a -> IO Bool
vioc_isopen (IORef (Bool, String) -> IO Bool)
-> (StreamReader -> IORef (Bool, String))
-> StreamReader
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamReader -> IORef (Bool, String)
srv
    vGetChar :: StreamReader -> IO Char
vGetChar StreamReader
h = do StreamReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF StreamReader
h
                    String
c <- IORef (Bool, String) -> IO String
forall a. VIOCloseSupport a -> IO a
vioc_get (StreamReader -> IORef (Bool, String)
srv StreamReader
h)
                    let retval :: Char
retval = String -> Char
forall a. [a] -> a
head String
c
                    IORef (Bool, String) -> String -> IO ()
forall a. VIOCloseSupport a -> a -> IO ()
vioc_set (StreamReader -> IORef (Bool, String)
srv StreamReader
h) (String -> String
forall a. [a] -> [a]
tail String
c)
                    Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
retval

    vGetContents :: StreamReader -> IO String
vGetContents StreamReader
h = do StreamReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF StreamReader
h
                        String
c <- IORef (Bool, String) -> IO String
forall a. VIOCloseSupport a -> IO a
vioc_get (StreamReader -> IORef (Bool, String)
srv StreamReader
h)
                        StreamReader -> IO ()
forall a. HVIO a => a -> IO ()
vClose StreamReader
h
                        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
c
    vIsReadable :: StreamReader -> IO Bool
vIsReadable StreamReader
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

----------------------------------------------------------------------
-- Buffers
----------------------------------------------------------------------
{- | A 'MemoryBuffer' simulates true I\/O, but uses an in-memory buffer instead
of on-disk storage.

It provides
a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter',
and 'HVIOSeeker').  However, it maintains an in-memory buffer with the
contents of the file, rather than an actual on-disk file.  You can access
the entire contents of this buffer at any time.  This can be quite useful
for testing I\/O code, or for cases where existing APIs use I\/O, but you
prefer a String representation.  You can create a 'MemoryBuffer' with a call
to 'newMemoryBuffer'.

The present 'MemoryBuffer' implementation is rather inefficient, particularly
when reading towards the end of large files.  It's best used for smallish
data storage.  This problem will be fixed eventually.
-}
data MemoryBuffer = MemoryBuffer (String -> IO ()) (VIOCloseSupport (Int, String))

{- | Create a new 'MemoryBuffer' instance.  The buffer is initialized
to the value passed, and the pointer is placed at the beginning of the file.

You can put things in it by using the normal 'vPutStr' calls, and reset to
the beginning by using the normal 'vRewind' call.

The function is called when 'vClose' is called, and is passed the contents of
the buffer at close time.  You can use 'mbDefaultCloseFunc' if you don't want to
do anything.

To create an empty buffer, pass the initial value @\"\"@. -}
newMemoryBuffer :: String               -- ^ Initial Contents
                -> (String -> IO ())    -- ^ close func
                -> IO MemoryBuffer
newMemoryBuffer :: String -> (String -> IO ()) -> IO MemoryBuffer
newMemoryBuffer String
initval String -> IO ()
closefunc = do IORef (Bool, (Int, String))
ref <- (Bool, (Int, String)) -> IO (IORef (Bool, (Int, String)))
forall a. a -> IO (IORef a)
newIORef (Bool
True, (Int
0, String
initval))
                                       MemoryBuffer -> IO MemoryBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> IO ()) -> IORef (Bool, (Int, String)) -> MemoryBuffer
MemoryBuffer String -> IO ()
closefunc IORef (Bool, (Int, String))
ref)

{- | Default (no-op) memory buf close function. -}
mbDefaultCloseFunc :: String -> IO ()
mbDefaultCloseFunc :: String -> IO ()
mbDefaultCloseFunc String
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

vrv :: MemoryBuffer -> VIOCloseSupport (Int, String)
vrv :: MemoryBuffer -> IORef (Bool, (Int, String))
vrv (MemoryBuffer String -> IO ()
_ IORef (Bool, (Int, String))
x) = IORef (Bool, (Int, String))
x

{- | Grab the entire contents of the buffer as a string.
Unlike 'vGetContents', this has no effect on the open status of the
item, the EOF status, or the current position of the file pointer. -}
getMemoryBuffer :: MemoryBuffer -> IO String
getMemoryBuffer :: MemoryBuffer -> IO String
getMemoryBuffer MemoryBuffer
h = do (Int, String)
c <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
                       String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
c)

instance Show MemoryBuffer where
    show :: MemoryBuffer -> String
show MemoryBuffer
_ = String
"<MemoryBuffer>"

instance HVIO MemoryBuffer where
    vClose :: MemoryBuffer -> IO ()
vClose MemoryBuffer
x = do Bool
wasopen <- MemoryBuffer -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsOpen MemoryBuffer
x
                  IORef (Bool, (Int, String)) -> IO ()
forall a. VIOCloseSupport a -> IO ()
vioc_close (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
x)
                  if Bool
wasopen
                     then do String
c <- MemoryBuffer -> IO String
getMemoryBuffer MemoryBuffer
x
                             case MemoryBuffer
x of
                                 MemoryBuffer String -> IO ()
cf IORef (Bool, (Int, String))
_ -> String -> IO ()
cf String
c
                     else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    vIsEOF :: MemoryBuffer -> IO Bool
vIsEOF MemoryBuffer
h = do MemoryBuffer -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen MemoryBuffer
h
                  (Int, String)
c <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
c)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ((Int, String) -> Int
forall a b. (a, b) -> a
fst (Int, String)
c))
    vIsOpen :: MemoryBuffer -> IO Bool
vIsOpen = IORef (Bool, (Int, String)) -> IO Bool
forall a. VIOCloseSupport a -> IO Bool
vioc_isopen (IORef (Bool, (Int, String)) -> IO Bool)
-> (MemoryBuffer -> IORef (Bool, (Int, String)))
-> MemoryBuffer
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBuffer -> IORef (Bool, (Int, String))
vrv
    vGetChar :: MemoryBuffer -> IO Char
vGetChar MemoryBuffer
h = do MemoryBuffer -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF MemoryBuffer
h
                    (Int, String)
c <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
                    let retval :: Char
retval = ((Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
c) String -> Int -> Char
forall a. [a] -> Int -> a
!! ((Int, String) -> Int
forall a b. (a, b) -> a
fst (Int, String)
c)
                    IORef (Bool, (Int, String)) -> (Int, String) -> IO ()
forall a. VIOCloseSupport a -> a -> IO ()
vioc_set (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h) (Int -> Int
forall a. Enum a => a -> a
succ ((Int, String) -> Int
forall a b. (a, b) -> a
fst (Int, String)
c), (Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
c)
                    Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
retval
    vGetContents :: MemoryBuffer -> IO String
vGetContents MemoryBuffer
h = do MemoryBuffer -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF MemoryBuffer
h
                        (Int, String)
v <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
                        let retval :: String
retval = Int -> String -> String
forall a. Int -> [a] -> [a]
drop ((Int, String) -> Int
forall a b. (a, b) -> a
fst (Int, String)
v) ((Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
v)
                        IORef (Bool, (Int, String)) -> (Int, String) -> IO ()
forall a. VIOCloseSupport a -> a -> IO ()
vioc_set (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h) (-Int
1, String
"")
                        MemoryBuffer -> IO ()
forall a. HVIO a => a -> IO ()
vClose MemoryBuffer
h
                        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
retval
    vIsReadable :: MemoryBuffer -> IO Bool
vIsReadable MemoryBuffer
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    vPutStr :: MemoryBuffer -> String -> IO ()
vPutStr MemoryBuffer
h String
s = do (Int
pos, String
buf) <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
                     let (String
pre, String
post) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos String
buf
                     let newbuf :: String
newbuf = String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) String
post)
                     IORef (Bool, (Int, String)) -> (Int, String) -> IO ()
forall a. VIOCloseSupport a -> a -> IO ()
vioc_set (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s), String
newbuf)
    vPutChar :: MemoryBuffer -> Char -> IO ()
vPutChar MemoryBuffer
h Char
c = MemoryBuffer -> String -> IO ()
forall a. HVIO a => a -> String -> IO ()
vPutStr MemoryBuffer
h [Char
c]
    vIsWritable :: MemoryBuffer -> IO Bool
vIsWritable MemoryBuffer
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    vTell :: MemoryBuffer -> IO Integer
vTell MemoryBuffer
h = do (Int, String)
v <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
                 Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer) -> (Int -> Integer) -> Int -> IO Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> IO Integer) -> Int -> IO Integer
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> Int
forall a b. (a, b) -> a
fst (Int, String)
v)
    vSeek :: MemoryBuffer -> SeekMode -> Integer -> IO ()
vSeek MemoryBuffer
h SeekMode
seekmode Integer
seekposp =
        do (Int
pos, String
buf) <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
           let seekpos :: Int
seekpos = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
seekposp
           let newpos :: Int
newpos = case SeekMode
seekmode of
                             SeekMode
AbsoluteSeek -> Int
seekpos
                             SeekMode
RelativeSeek -> Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
seekpos
                             SeekMode
SeekFromEnd  -> (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
buf) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
seekpos
           let buf2 :: String
buf2 = String
buf String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Int
newpos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
buf)
                                then Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
newpos Int -> Int -> Int
forall a. Num a => a -> a -> a
- (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
buf)) Char
'\0'
                                else []
           IORef (Bool, (Int, String)) -> (Int, String) -> IO ()
forall a. VIOCloseSupport a -> a -> IO ()
vioc_set (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h) (Int
newpos, String
buf2)
    vIsSeekable :: MemoryBuffer -> IO Bool
vIsSeekable MemoryBuffer
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

----------------------------------------------------------------------
-- Pipes
----------------------------------------------------------------------
{- | Create a Haskell pipe.

These pipes are analogous to the Unix
pipes that are available from System.Posix, but don't require Unix and work
only in Haskell.  When you create a pipe, you actually get two HVIO objects:
a 'PipeReader' and a 'PipeWriter'.  You must use the 'PipeWriter' in one
thread and the 'PipeReader' in another thread.  Data that's written to the
'PipeWriter' will then be available for reading with the 'PipeReader'.  The
pipes are implemented completely with existing Haskell threading primitives,
and require no special operating system support.  Unlike Unix pipes, these
pipes cannot be used across a fork().  Also unlike Unix pipes, these pipes
are portable and interact well with Haskell threads. -}
newHVIOPipe :: IO (PipeReader, PipeWriter)
newHVIOPipe :: IO (PipeReader, PipeWriter)
newHVIOPipe = do MVar PipeBit
mv <- IO (MVar PipeBit)
forall a. IO (MVar a)
newEmptyMVar
                 IORef (Bool, MVar PipeBit)
readerref <- (Bool, MVar PipeBit) -> IO (IORef (Bool, MVar PipeBit))
forall a. a -> IO (IORef a)
newIORef (Bool
True, MVar PipeBit
mv)
                 let reader :: PipeReader
reader = IORef (Bool, MVar PipeBit) -> PipeReader
PipeReader IORef (Bool, MVar PipeBit)
readerref
                 IORef (Bool, PipeReader)
writerref <- (Bool, PipeReader) -> IO (IORef (Bool, PipeReader))
forall a. a -> IO (IORef a)
newIORef (Bool
True, PipeReader
reader)
                 (PipeReader, PipeWriter) -> IO (PipeReader, PipeWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeReader
reader, IORef (Bool, PipeReader) -> PipeWriter
PipeWriter IORef (Bool, PipeReader)
writerref)

data PipeBit = PipeBit Char
             | PipeEOF
               deriving (PipeBit -> PipeBit -> Bool
(PipeBit -> PipeBit -> Bool)
-> (PipeBit -> PipeBit -> Bool) -> Eq PipeBit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PipeBit -> PipeBit -> Bool
$c/= :: PipeBit -> PipeBit -> Bool
== :: PipeBit -> PipeBit -> Bool
$c== :: PipeBit -> PipeBit -> Bool
Eq, Int -> PipeBit -> String -> String
[PipeBit] -> String -> String
PipeBit -> String
(Int -> PipeBit -> String -> String)
-> (PipeBit -> String)
-> ([PipeBit] -> String -> String)
-> Show PipeBit
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PipeBit] -> String -> String
$cshowList :: [PipeBit] -> String -> String
show :: PipeBit -> String
$cshow :: PipeBit -> String
showsPrec :: Int -> PipeBit -> String -> String
$cshowsPrec :: Int -> PipeBit -> String -> String
Show)

{- | The reading side of a Haskell pipe.  Please see 'newHVIOPipe' for more
details. -}
newtype PipeReader = PipeReader (VIOCloseSupport (MVar PipeBit))

{- | The writing side of a Haskell pipe.  Please see 'newHVIOPipe' for more
details. -}
newtype PipeWriter = PipeWriter (VIOCloseSupport PipeReader)

------------------------------
-- Pipe Reader
------------------------------
prv :: PipeReader -> VIOCloseSupport (MVar PipeBit)
prv :: PipeReader -> IORef (Bool, MVar PipeBit)
prv (PipeReader IORef (Bool, MVar PipeBit)
x) = IORef (Bool, MVar PipeBit)
x

instance Show PipeReader where
    show :: PipeReader -> String
show PipeReader
_ = String
"<PipeReader>"

pr_getc :: PipeReader -> IO PipeBit
pr_getc :: PipeReader -> IO PipeBit
pr_getc PipeReader
h = do MVar PipeBit
mv <- IORef (Bool, MVar PipeBit) -> IO (MVar PipeBit)
forall a. VIOCloseSupport a -> IO a
vioc_get (PipeReader -> IORef (Bool, MVar PipeBit)
prv PipeReader
h)
               MVar PipeBit -> IO PipeBit
forall a. MVar a -> IO a
takeMVar MVar PipeBit
mv

instance HVIO PipeReader where
    vClose :: PipeReader -> IO ()
vClose = IORef (Bool, MVar PipeBit) -> IO ()
forall a. VIOCloseSupport a -> IO ()
vioc_close (IORef (Bool, MVar PipeBit) -> IO ())
-> (PipeReader -> IORef (Bool, MVar PipeBit))
-> PipeReader
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PipeReader -> IORef (Bool, MVar PipeBit)
prv
    vIsOpen :: PipeReader -> IO Bool
vIsOpen = IORef (Bool, MVar PipeBit) -> IO Bool
forall a. VIOCloseSupport a -> IO Bool
vioc_isopen (IORef (Bool, MVar PipeBit) -> IO Bool)
-> (PipeReader -> IORef (Bool, MVar PipeBit))
-> PipeReader
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PipeReader -> IORef (Bool, MVar PipeBit)
prv
    vIsEOF :: PipeReader -> IO Bool
vIsEOF PipeReader
h = do PipeReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen PipeReader
h
                  MVar PipeBit
mv <- IORef (Bool, MVar PipeBit) -> IO (MVar PipeBit)
forall a. VIOCloseSupport a -> IO a
vioc_get (PipeReader -> IORef (Bool, MVar PipeBit)
prv PipeReader
h)
                  PipeBit
dat <- MVar PipeBit -> IO PipeBit
forall a. MVar a -> IO a
readMVar MVar PipeBit
mv
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeBit
dat PipeBit -> PipeBit -> Bool
forall a. Eq a => a -> a -> Bool
== PipeBit
PipeEOF)

    vGetChar :: PipeReader -> IO Char
vGetChar PipeReader
h = do PipeReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF PipeReader
h
                    PipeBit
c <- PipeReader -> IO PipeBit
pr_getc PipeReader
h
                    case PipeBit
c of
                        PipeBit Char
x -> Char -> IO Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
x
                        -- vTestEOF should eliminate this case
                        PipeBit
_ -> String -> IO Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Internal error in HVIOReader vGetChar"
    vGetContents :: PipeReader -> IO String
vGetContents PipeReader
h =
        let loop :: IO String
loop = do PipeBit
c <- PipeReader -> IO PipeBit
pr_getc PipeReader
h
                      case PipeBit
c of
                          PipeBit
PipeEOF -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return []
                          PipeBit Char
x -> do String
next <- IO String
loop
                                          String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
next)
        in do PipeReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF PipeReader
h
              IO String
loop
    vIsReadable :: PipeReader -> IO Bool
vIsReadable PipeReader
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

------------------------------
-- Pipe Writer
------------------------------
pwv :: PipeWriter -> VIOCloseSupport PipeReader
pwv :: PipeWriter -> IORef (Bool, PipeReader)
pwv (PipeWriter IORef (Bool, PipeReader)
x) = IORef (Bool, PipeReader)
x

pwmv :: PipeWriter -> IO (MVar PipeBit)
pwmv :: PipeWriter -> IO (MVar PipeBit)
pwmv (PipeWriter IORef (Bool, PipeReader)
x) = do PipeReader
mv1 <- IORef (Bool, PipeReader) -> IO PipeReader
forall a. VIOCloseSupport a -> IO a
vioc_get IORef (Bool, PipeReader)
x
                         IORef (Bool, MVar PipeBit) -> IO (MVar PipeBit)
forall a. VIOCloseSupport a -> IO a
vioc_get (PipeReader -> IORef (Bool, MVar PipeBit)
prv PipeReader
mv1)

instance Show PipeWriter where
    show :: PipeWriter -> String
show PipeWriter
_ = String
"<PipeWriter>"

instance HVIO PipeWriter where
    vClose :: PipeWriter -> IO ()
vClose PipeWriter
h = do Bool
o <- PipeWriter -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsOpen PipeWriter
h
                  if Bool
o then do
                            MVar PipeBit
mv <- PipeWriter -> IO (MVar PipeBit)
pwmv PipeWriter
h
                            MVar PipeBit -> PipeBit -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar PipeBit
mv PipeBit
PipeEOF
                            IORef (Bool, PipeReader) -> IO ()
forall a. VIOCloseSupport a -> IO ()
vioc_close (PipeWriter -> IORef (Bool, PipeReader)
pwv PipeWriter
h)
                     else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    vIsOpen :: PipeWriter -> IO Bool
vIsOpen = IORef (Bool, PipeReader) -> IO Bool
forall a. VIOCloseSupport a -> IO Bool
vioc_isopen (IORef (Bool, PipeReader) -> IO Bool)
-> (PipeWriter -> IORef (Bool, PipeReader))
-> PipeWriter
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PipeWriter -> IORef (Bool, PipeReader)
pwv
    vIsEOF :: PipeWriter -> IO Bool
vIsEOF PipeWriter
h = do PipeWriter -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen PipeWriter
h
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    -- FIXME: race condition below (could be closed after testing)
    vPutChar :: PipeWriter -> Char -> IO ()
vPutChar PipeWriter
h Char
c = do PipeWriter -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen PipeWriter
h
                      PipeReader
child <- IORef (Bool, PipeReader) -> IO PipeReader
forall a. VIOCloseSupport a -> IO a
vioc_get (PipeWriter -> IORef (Bool, PipeReader)
pwv PipeWriter
h)
                      Bool
copen <- PipeReader -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsOpen PipeReader
child
                      if Bool
copen
                         then do MVar PipeBit
mv <- PipeWriter -> IO (MVar PipeBit)
pwmv PipeWriter
h
                                 MVar PipeBit -> PipeBit -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar PipeBit
mv (Char -> PipeBit
PipeBit Char
c)
                         else String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PipeWriter: Couldn't write to pipe because child end is closed"
    vIsWritable :: PipeWriter -> IO Bool
vIsWritable PipeWriter
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True