{-# LANGUAGE Safe #-}
module System.IO.HVIO(
HVIO(..),
StreamReader, newStreamReader,
MemoryBuffer, newMemoryBuffer,
mbDefaultCloseFunc, getMemoryBuffer,
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 )
class (Show a) => HVIO a where
vClose :: a -> IO ()
vIsOpen :: a -> IO Bool
vIsClosed :: a -> IO Bool
vTestOpen :: a -> IO ()
vIsEOF :: a -> IO Bool
vShow :: a -> IO String
vMkIOError :: a -> IOErrorType -> String -> Maybe FilePath -> IOError
vThrow :: a -> IOErrorType -> IO b
vGetFP :: a -> IO (Maybe FilePath)
vTestEOF :: a -> IO ()
vGetChar :: a -> IO Char
vGetLine :: a -> IO String
vGetContents :: a -> IO String
vReady :: a -> IO Bool
vIsReadable :: a -> IO Bool
vPutChar :: a -> Char -> IO ()
vPutStr :: a -> String -> IO ()
vPutStrLn :: a -> String -> IO ()
vPrint :: Show b => a -> b -> IO ()
vFlush :: a -> IO ()
vIsWritable :: a -> IO Bool
vSeek :: a -> SeekMode -> Integer -> IO ()
vTell :: a -> IO Integer
vRewind :: a -> IO ()
vIsSeekable :: a -> IO Bool
vSetBuffering :: a -> BufferMode -> IO ()
vGetBuffering :: a -> IO BufferMode
vPutBuf :: a -> Ptr b -> Int -> IO ()
vGetBuf :: a -> Ptr b -> Int -> IO Int
vSetBuffering a
_ BufferMode
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
vGetBuffering a
_ = BufferMode -> IO BufferMode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BufferMode
NoBuffering
vShow a
x = String -> IO String
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
vThrow a
h IOErrorType
et = do
fp <- a -> IO (Maybe String)
forall a. HVIO a => a -> IO (Maybe String)
vGetFP a
h
ioError (vMkIOError h et "" fp)
vTestEOF a
h = do e <- a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsEOF a
h
if e then vThrow h eofErrorType
else 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall a. a -> IO a
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 e <- a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsClosed a
h
if e then vThrow h illegalOperationErrorType
else return ()
vIsReadable a
_ = Bool -> IO Bool
forall a. a -> IO a
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 c <- a -> IO Char
forall a. HVIO a => a -> IO Char
vGetChar a
h
case c of
Char
'\n' -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
accum
Char
x -> String
accum String -> IO String -> IO String
forall a b. a -> b -> b
`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 a. a -> IO a
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 firstchar <- a -> IO Char
forall a. HVIO a => a -> IO Char
vGetChar a
h
case firstchar of
Char
'\n' -> String -> IO String
forall a. a -> IO a
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 c <- a -> IO Char
forall a. HVIO a => a -> IO Char
vGetChar a
h
next <- loop
c `seq` return (c : next)
handler :: IOError -> IO [a]
handler IOError
e = if IOError -> Bool
isEOFError IOError
e then [a] -> IO [a]
forall a. 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 loop
vReady a
h = do a -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF a
h
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
vIsWritable a
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
vPutStr a
_ [] = () -> IO ()
forall a. a -> IO a
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 a. a -> IO a
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 b. a -> IOErrorType -> IO b
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
vSeek a
h SeekMode
_ Integer
_ = a -> IOErrorType -> IO ()
forall b. a -> IOErrorType -> IO b
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
vTell a
h = a -> IOErrorType -> IO Integer
forall b. a -> IOErrorType -> IO b
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
vGetChar a
h = a -> IOErrorType -> IO Char
forall b. a -> IOErrorType -> IO b
forall a b. HVIO a => a -> IOErrorType -> IO b
vThrow a
h IOErrorType
illegalOperationErrorType
vPutBuf a
h Ptr b
buf Int
len =
do str <- CStringLen -> IO String
peekCStringLen (Ptr b -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr b
buf, Int
len)
vPutStr h 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return t
accum
worker Ptr b
buf t
len t
accum =
do iseof <- a -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsEOF a
h
if iseof
then return accum
else do c <- vGetChar h
let cc = Char -> CChar
castCharToCChar Char
c
poke (castPtr buf) cc
let newptr = Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr b
buf Int
1
worker newptr (len - 1) (accum + 1)
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
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO a
forall a. 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))
newtype StreamReader = StreamReader (VIOCloseSupport String)
newStreamReader :: String
-> IO StreamReader
newStreamReader :: String -> IO StreamReader
newStreamReader String
s = do ref <- (Bool, String) -> IO (IORef (Bool, String))
forall a. a -> IO (IORef a)
newIORef (Bool
True, String
s)
return (StreamReader 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
d <- IORef (Bool, String) -> IO String
forall a. VIOCloseSupport a -> IO a
vioc_get (StreamReader -> IORef (Bool, String)
srv StreamReader
h)
return $ case 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
c <- IORef (Bool, String) -> IO String
forall a. VIOCloseSupport a -> IO a
vioc_get (StreamReader -> IORef (Bool, String)
srv StreamReader
h)
let retval = String -> Char
forall a. HasCallStack => [a] -> a
head String
c
vioc_set (srv h) (tail c)
return retval
vGetContents :: StreamReader -> IO String
vGetContents StreamReader
h = do StreamReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF StreamReader
h
c <- IORef (Bool, String) -> IO String
forall a. VIOCloseSupport a -> IO a
vioc_get (StreamReader -> IORef (Bool, String)
srv StreamReader
h)
vClose h
return c
vIsReadable :: StreamReader -> IO Bool
vIsReadable StreamReader
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
data MemoryBuffer = MemoryBuffer (String -> IO ()) (VIOCloseSupport (Int, String))
newMemoryBuffer :: String
-> (String -> IO ())
-> IO MemoryBuffer
newMemoryBuffer :: String -> (String -> IO ()) -> IO MemoryBuffer
newMemoryBuffer String
initval String -> IO ()
closefunc = do ref <- (Bool, (Int, String)) -> IO (IORef (Bool, (Int, String)))
forall a. a -> IO (IORef a)
newIORef (Bool
True, (Int
0, String
initval))
return (MemoryBuffer closefunc ref)
mbDefaultCloseFunc :: String -> IO ()
mbDefaultCloseFunc :: String -> IO ()
mbDefaultCloseFunc String
_ = () -> IO ()
forall a. a -> IO a
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
getMemoryBuffer :: MemoryBuffer -> IO String
getMemoryBuffer :: MemoryBuffer -> IO String
getMemoryBuffer MemoryBuffer
h = do c <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
return (snd c)
instance Show MemoryBuffer where
show :: MemoryBuffer -> String
show MemoryBuffer
_ = String
"<MemoryBuffer>"
instance HVIO MemoryBuffer where
vClose :: MemoryBuffer -> IO ()
vClose MemoryBuffer
x = do wasopen <- MemoryBuffer -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsOpen MemoryBuffer
x
vioc_close (vrv x)
if wasopen
then do c <- getMemoryBuffer x
case x of
MemoryBuffer String -> IO ()
cf IORef (Bool, (Int, String))
_ -> String -> IO ()
cf String
c
else return ()
vIsEOF :: MemoryBuffer -> IO Bool
vIsEOF MemoryBuffer
h = do MemoryBuffer -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen MemoryBuffer
h
c <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
return ((length (snd c)) == (fst 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
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 = ((Int, String) -> String
forall a b. (a, b) -> b
snd (Int, String)
c) String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! ((Int, String) -> Int
forall a b. (a, b) -> a
fst (Int, String)
c)
vioc_set (vrv h) (succ (fst c), snd c)
return retval
vGetContents :: MemoryBuffer -> IO String
vGetContents MemoryBuffer
h = do MemoryBuffer -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF MemoryBuffer
h
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 = 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)
vioc_set (vrv h) (-1, "")
vClose h
return retval
vIsReadable :: MemoryBuffer -> IO Bool
vIsReadable MemoryBuffer
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
vPutStr :: MemoryBuffer -> String -> IO ()
vPutStr MemoryBuffer
h String
s = do (pos, 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 (pre, post) = splitAt pos buf
let 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) String
post)
vioc_set (vrv h) (pos + (length s), 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
vTell :: MemoryBuffer -> IO Integer
vTell MemoryBuffer
h = do v <- IORef (Bool, (Int, String)) -> IO (Int, String)
forall a. VIOCloseSupport a -> IO a
vioc_get (MemoryBuffer -> IORef (Bool, (Int, String))
vrv MemoryBuffer
h)
return . fromIntegral $ (fst v)
vSeek :: MemoryBuffer -> SeekMode -> Integer -> IO ()
vSeek MemoryBuffer
h SeekMode
seekmode Integer
seekposp =
do (pos, 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 = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
seekposp
let 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 a. [a] -> 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
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 a. [a] -> 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
buf)) Char
'\0'
else []
vioc_set (vrv h) (newpos, buf2)
vIsSeekable :: MemoryBuffer -> IO Bool
vIsSeekable MemoryBuffer
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
newHVIOPipe :: IO (PipeReader, PipeWriter)
newHVIOPipe :: IO (PipeReader, PipeWriter)
newHVIOPipe = do mv <- IO (MVar PipeBit)
forall a. IO (MVar a)
newEmptyMVar
readerref <- newIORef (True, mv)
let reader = IORef (Bool, MVar PipeBit) -> PipeReader
PipeReader IORef (Bool, MVar PipeBit)
readerref
writerref <- newIORef (True, reader)
return (reader, PipeWriter 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
$c== :: PipeBit -> PipeBit -> Bool
== :: PipeBit -> PipeBit -> Bool
$c/= :: PipeBit -> PipeBit -> Bool
/= :: 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
$cshowsPrec :: Int -> PipeBit -> String -> String
showsPrec :: Int -> PipeBit -> String -> String
$cshow :: PipeBit -> String
show :: PipeBit -> String
$cshowList :: [PipeBit] -> String -> String
showList :: [PipeBit] -> String -> String
Show)
newtype PipeReader = PipeReader (VIOCloseSupport (MVar PipeBit))
newtype PipeWriter = PipeWriter (VIOCloseSupport PipeReader)
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 mv <- IORef (Bool, MVar PipeBit) -> IO (MVar PipeBit)
forall a. VIOCloseSupport a -> IO a
vioc_get (PipeReader -> IORef (Bool, MVar PipeBit)
prv PipeReader
h)
takeMVar 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
mv <- IORef (Bool, MVar PipeBit) -> IO (MVar PipeBit)
forall a. VIOCloseSupport a -> IO a
vioc_get (PipeReader -> IORef (Bool, MVar PipeBit)
prv PipeReader
h)
dat <- readMVar mv
return (dat == PipeEOF)
vGetChar :: PipeReader -> IO Char
vGetChar PipeReader
h = do PipeReader -> IO ()
forall a. HVIO a => a -> IO ()
vTestEOF PipeReader
h
c <- PipeReader -> IO PipeBit
pr_getc PipeReader
h
case c of
PipeBit Char
x -> Char -> IO Char
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
x
PipeBit
_ -> String -> IO Char
forall a. String -> IO a
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 c <- PipeReader -> IO PipeBit
pr_getc PipeReader
h
case c of
PipeBit
PipeEOF -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
PipeBit Char
x -> do next <- IO String
loop
return (x : 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
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 mv1 <- IORef (Bool, PipeReader) -> IO PipeReader
forall a. VIOCloseSupport a -> IO a
vioc_get IORef (Bool, PipeReader)
x
vioc_get (prv mv1)
instance Show PipeWriter where
show :: PipeWriter -> String
show PipeWriter
_ = String
"<PipeWriter>"
instance HVIO PipeWriter where
vClose :: PipeWriter -> IO ()
vClose PipeWriter
h = do o <- PipeWriter -> IO Bool
forall a. HVIO a => a -> IO Bool
vIsOpen PipeWriter
h
if o then do
mv <- pwmv h
putMVar mv PipeEOF
vioc_close (pwv h)
else 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
vPutChar :: PipeWriter -> Char -> IO ()
vPutChar PipeWriter
h Char
c = do PipeWriter -> IO ()
forall a. HVIO a => a -> IO ()
vTestOpen PipeWriter
h
child <- IORef (Bool, PipeReader) -> IO PipeReader
forall a. VIOCloseSupport a -> IO a
vioc_get (PipeWriter -> IORef (Bool, PipeReader)
pwv PipeWriter
h)
copen <- vIsOpen child
if copen
then do mv <- pwmv h
putMVar mv (PipeBit c)
else fail "PipeWriter: Couldn't write to pipe because child end is closed"
vIsWritable :: PipeWriter -> IO Bool
vIsWritable PipeWriter
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True