{-# LANGUAGE Trustworthy #-}
module System.IO.Binary(
BinaryConvertible(..),
hBlockCopy, blockCopy,
copyFileBlocksToFile,
hPutBufStr, putBufStr, hGetBufStr, getBufStr,
hFullGetBufStr, fullGetBufStr,
hGetBlocks, getBlocks, hFullGetBlocks, fullGetBlocks,
readBinaryFile, writeBinaryFile,
hBlockInteract, blockInteract,
hFullBlockInteract, fullBlockInteract
) where
import Data.Word (Word8())
import Foreign.C.String (peekCStringLen, withCString)
import Foreign.C.Types (CChar())
import Foreign.ForeignPtr
( ForeignPtr, mallocForeignPtrArray, withForeignPtr )
import Foreign.Marshal.Array (peekArray, withArray)
import Foreign.Ptr ( Ptr, castPtr )
import System.IO
( stdout,
hClose,
openBinaryFile,
stdin,
IOMode(WriteMode, ReadMode) )
import System.IO.HVFS
( SystemFS(SystemFS),
HVFSOpenable(vOpenBinaryFile),
HVFSOpenEncap(HVFSOpenEncap) )
import System.IO.HVIO
( HVIO(vClose, vGetBuf, vPutBuf, vGetContents, vPutStr) )
import System.IO.Unsafe (unsafeInterleaveIO)
class (Eq a, Show a) => BinaryConvertible a where
toBuf :: [a] -> (Ptr CChar -> IO c) -> IO c
fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [a]
instance BinaryConvertible Char where
toBuf :: [Char] -> (Ptr CChar -> IO c) -> IO c
toBuf = [Char] -> (Ptr CChar -> IO c) -> IO c
forall c. [Char] -> (Ptr CChar -> IO c) -> IO c
withCString
fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [Char]
fromBuf Int
len Ptr CChar -> IO Int
func =
do ForeignPtr CChar
fbuf <- Int -> IO (ForeignPtr CChar)
forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
ForeignPtr CChar -> (Ptr CChar -> IO [Char]) -> IO [Char]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuf Ptr CChar -> IO [Char]
handler
where handler :: Ptr CChar -> IO [Char]
handler Ptr CChar
ptr =
do Int
bytesread <- Ptr CChar -> IO Int
func Ptr CChar
ptr
CStringLen -> IO [Char]
peekCStringLen (Ptr CChar
ptr, Int
bytesread)
instance BinaryConvertible Word8 where
toBuf :: [Word8] -> (Ptr CChar -> IO c) -> IO c
toBuf [Word8]
hslist Ptr CChar -> IO c
func = [Word8] -> (Ptr Word8 -> IO c) -> IO c
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Word8]
hslist (\Ptr Word8
ptr -> Ptr CChar -> IO c
func (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr))
fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [Word8]
fromBuf Int
len Ptr CChar -> IO Int
func =
do (ForeignPtr Word8
fbuf::(ForeignPtr Word8)) <- Int -> IO (ForeignPtr Word8)
forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
ForeignPtr Word8 -> (Ptr Word8 -> IO [Word8]) -> IO [Word8]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fbuf Ptr Word8 -> IO [Word8]
forall a. Storable a => Ptr a -> IO [a]
handler
where handler :: Ptr a -> IO [a]
handler Ptr a
ptr =
do Int
bytesread <- Ptr CChar -> IO Int
func (Ptr a -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr)
Int -> Ptr a -> IO [a]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
bytesread Ptr a
ptr
hPutBufStr :: (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
hPutBufStr :: a -> [b] -> IO ()
hPutBufStr a
f [b]
s = [b] -> (Ptr CChar -> IO ()) -> IO ()
forall a c.
BinaryConvertible a =>
[a] -> (Ptr CChar -> IO c) -> IO c
toBuf [b]
s (\Ptr CChar
cs -> a -> Ptr CChar -> Int -> IO ()
forall a b. HVIO a => a -> Ptr b -> Int -> IO ()
vPutBuf a
f Ptr CChar
cs ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
s))
putBufStr :: (BinaryConvertible b) => [b] -> IO ()
putBufStr :: [b] -> IO ()
putBufStr = Handle -> [b] -> IO ()
forall a b. (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
hPutBufStr Handle
stdout
hGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr :: a -> Int -> IO [b]
hGetBufStr a
f Int
count = Int -> (Ptr CChar -> IO Int) -> IO [b]
forall a.
BinaryConvertible a =>
Int -> (Ptr CChar -> IO Int) -> IO [a]
fromBuf Int
count (\Ptr CChar
buf -> a -> Ptr CChar -> Int -> IO Int
forall a b. HVIO a => a -> Ptr b -> Int -> IO Int
vGetBuf a
f Ptr CChar
buf Int
count)
getBufStr :: (BinaryConvertible b) => Int -> IO [b]
getBufStr :: Int -> IO [b]
getBufStr = Handle -> Int -> IO [b]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr Handle
stdin
hFullGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr :: a -> Int -> IO [b]
hFullGetBufStr a
_ Int
0 = [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
hFullGetBufStr a
f Int
count = do
[b]
thisstr <- a -> Int -> IO [b]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr a
f Int
count
if [b]
thisstr [b] -> [b] -> Bool
forall a. Eq a => a -> a -> Bool
== []
then [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[b]
remainder <- a -> Int -> IO [b]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr a
f (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
thisstr))
[b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
thisstr [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
remainder)
fullGetBufStr :: BinaryConvertible b => Int -> IO [b]
fullGetBufStr :: Int -> IO [b]
fullGetBufStr = Handle -> Int -> IO [b]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr Handle
stdin
hPutBlocks :: (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
hPutBlocks :: a -> [[b]] -> IO ()
hPutBlocks a
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
hPutBlocks a
h ([b]
x:[[b]]
xs) = do
a -> [b] -> IO ()
forall a b. (HVIO a, BinaryConvertible b) => a -> [b] -> IO ()
hPutBufStr a
h [b]
x
a -> [[b]] -> IO ()
forall a b. (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
hPutBlocks a
h [[b]]
xs
hGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hGetBlocks :: a -> Int -> IO [[b]]
hGetBlocks = (a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
forall a b.
(HVIO a, BinaryConvertible b) =>
(a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil a -> Int -> IO [b]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hGetBufStr
getBlocks :: BinaryConvertible b => Int -> IO [[b]]
getBlocks :: Int -> IO [[b]]
getBlocks = Handle -> Int -> IO [[b]]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hGetBlocks Handle
stdin
hFullGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hFullGetBlocks :: a -> Int -> IO [[b]]
hFullGetBlocks = (a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
forall a b.
(HVIO a, BinaryConvertible b) =>
(a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil a -> Int -> IO [b]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [b]
hFullGetBufStr
fullGetBlocks :: BinaryConvertible b => Int -> IO [[b]]
fullGetBlocks :: Int -> IO [[b]]
fullGetBlocks = Handle -> Int -> IO [[b]]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hFullGetBlocks Handle
stdin
hGetBlocksUtil :: (HVIO a, BinaryConvertible b) => (a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil :: (a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil a -> Int -> IO [b]
readfunc a
h Int
count =
IO [[b]] -> IO [[b]]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [[b]] -> IO [[b]]) -> IO [[b]] -> IO [[b]]
forall a b. (a -> b) -> a -> b
$ do
[b]
block <- a -> Int -> IO [b]
readfunc a
h Int
count
if [b]
block [b] -> [b] -> Bool
forall a. Eq a => a -> a -> Bool
== []
then [[b]] -> IO [[b]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[[b]]
remainder <- (a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
forall a b.
(HVIO a, BinaryConvertible b) =>
(a -> Int -> IO [b]) -> a -> Int -> IO [[b]]
hGetBlocksUtil a -> Int -> IO [b]
readfunc a
h Int
count
[[b]] -> IO [[b]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
block [b] -> [[b]] -> [[b]]
forall a. a -> [a] -> [a]
: [[b]]
remainder)
hBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteract :: Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteract = (a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
(a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil a -> Int -> IO [[b]]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hGetBlocks
blockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO ()
blockInteract :: Int -> ([[b]] -> [[c]]) -> IO ()
blockInteract Int
x = Int -> Handle -> Handle -> ([[b]] -> [[c]]) -> IO ()
forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteract Int
x Handle
stdin Handle
stdout
hFullBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hFullBlockInteract :: Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hFullBlockInteract = (a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
(a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil a -> Int -> IO [[b]]
forall a b. (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]]
hFullGetBlocks
fullBlockInteract :: (BinaryConvertible b, BinaryConvertible c) =>
Int -> ([[b]] -> [[c]]) -> IO ()
fullBlockInteract :: Int -> ([[b]] -> [[c]]) -> IO ()
fullBlockInteract Int
x = Int -> Handle -> Handle -> ([[b]] -> [[c]]) -> IO ()
forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hFullBlockInteract Int
x Handle
stdin Handle
stdout
hBlockInteractUtil :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
(a -> Int -> IO [[b]]) -> Int ->
a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil :: (a -> Int -> IO [[b]])
-> Int -> a -> d -> ([[b]] -> [[c]]) -> IO ()
hBlockInteractUtil a -> Int -> IO [[b]]
blockreader Int
blocksize a
hin d
hout [[b]] -> [[c]]
func =
do
[[b]]
blocks <- a -> Int -> IO [[b]]
blockreader a
hin Int
blocksize
d -> [[c]] -> IO ()
forall a b. (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO ()
hPutBlocks d
hout ([[b]] -> [[c]]
func [[b]]
blocks)
hBlockCopy :: (HVIO a, HVIO b) => Int -> a -> b -> IO ()
hBlockCopy :: Int -> a -> b -> IO ()
hBlockCopy Int
bs a
hin b
hout =
do (ForeignPtr CChar
fbuf::ForeignPtr CChar) <- Int -> IO (ForeignPtr CChar)
forall a. Storable a => Int -> IO (ForeignPtr a)
mallocForeignPtrArray (Int
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
ForeignPtr CChar -> (Ptr CChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fbuf Ptr CChar -> IO ()
forall b. Ptr b -> IO ()
handler
where handler :: Ptr b -> IO ()
handler Ptr b
ptr =
do Int
bytesread <- a -> Ptr b -> Int -> IO Int
forall a b. HVIO a => a -> Ptr b -> Int -> IO Int
vGetBuf a
hin Ptr b
ptr Int
bs
if Int
bytesread Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then do b -> Ptr b -> Int -> IO ()
forall a b. HVIO a => a -> Ptr b -> Int -> IO ()
vPutBuf b
hout Ptr b
ptr Int
bytesread
Ptr b -> IO ()
handler Ptr b
ptr
else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
blockCopy :: Int -> IO ()
blockCopy :: Int -> IO ()
blockCopy Int
bs = Int -> Handle -> Handle -> IO ()
forall a b. (HVIO a, HVIO b) => Int -> a -> b -> IO ()
hBlockCopy Int
bs Handle
stdin Handle
stdout
copyFileBlocksToFile :: Int -> FilePath -> FilePath -> IO ()
copyFileBlocksToFile :: Int -> [Char] -> [Char] -> IO ()
copyFileBlocksToFile Int
bs [Char]
infn [Char]
outfn = do
Handle
hin <- [Char] -> IOMode -> IO Handle
openBinaryFile [Char]
infn IOMode
ReadMode
Handle
hout <- [Char] -> IOMode -> IO Handle
openBinaryFile [Char]
outfn IOMode
WriteMode
Int -> Handle -> Handle -> IO ()
forall a b. (HVIO a, HVIO b) => Int -> a -> b -> IO ()
hBlockCopy Int
bs Handle
hin Handle
hout
Handle -> IO ()
hClose Handle
hin
Handle -> IO ()
hClose Handle
hout
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
readBinaryFile :: FilePath -> IO String
readBinaryFile :: [Char] -> IO [Char]
readBinaryFile = SystemFS -> [Char] -> IO [Char]
forall a. HVFSOpenable a => a -> [Char] -> IO [Char]
vReadBinaryFile SystemFS
SystemFS
vReadBinaryFile :: (HVFSOpenable a) => a -> FilePath -> IO String
vReadBinaryFile :: a -> [Char] -> IO [Char]
vReadBinaryFile a
fs [Char]
fp =
a -> [Char] -> IOMode -> IO HVFSOpenEncap
forall a.
HVFSOpenable a =>
a -> [Char] -> IOMode -> IO HVFSOpenEncap
vOpenBinaryFile a
fs [Char]
fp IOMode
ReadMode IO HVFSOpenEncap -> (HVFSOpenEncap -> IO [Char]) -> IO [Char]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(HVFSOpenEncap a
h) -> a -> IO [Char]
forall a. HVIO a => a -> IO [Char]
vGetContents a
h)
writeBinaryFile :: FilePath -> String -> IO ()
writeBinaryFile :: [Char] -> [Char] -> IO ()
writeBinaryFile = SystemFS -> [Char] -> [Char] -> IO ()
forall a. HVFSOpenable a => a -> [Char] -> [Char] -> IO ()
vWriteBinaryFile SystemFS
SystemFS
vWriteBinaryFile :: (HVFSOpenable a) => a -> FilePath -> String -> IO ()
vWriteBinaryFile :: a -> [Char] -> [Char] -> IO ()
vWriteBinaryFile a
fs [Char]
name [Char]
str =
do HVFSOpenEncap
h <- a -> [Char] -> IOMode -> IO HVFSOpenEncap
forall a.
HVFSOpenable a =>
a -> [Char] -> IOMode -> IO HVFSOpenEncap
vOpenBinaryFile a
fs [Char]
name IOMode
WriteMode
case HVFSOpenEncap
h of
HVFSOpenEncap a
x -> do a -> [Char] -> IO ()
forall a. HVIO a => a -> [Char] -> IO ()
vPutStr a
x [Char]
str
a -> IO ()
forall a. HVIO a => a -> IO ()
vClose a
x