{-# 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
import Foreign.Marshal.Array (peekArray, withArray)
import Foreign.Ptr
import System.IO
import System.IO.HVFS
import System.IO.HVIO
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 :: forall c. [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 :: forall c. [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 :: forall a b. (HVIO a, BinaryConvertible b) => 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 :: forall b. BinaryConvertible b => [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 :: forall a b. (HVIO a, BinaryConvertible b) => 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 :: forall b. BinaryConvertible b => 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 :: forall a b. (HVIO a, BinaryConvertible b) => 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 :: forall b. BinaryConvertible b => 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 :: forall a b. (HVIO a, BinaryConvertible b) => 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 :: forall a b. (HVIO a, BinaryConvertible b) => 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 :: forall b. BinaryConvertible b => 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 :: forall a b. (HVIO a, BinaryConvertible b) => 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 :: forall b. BinaryConvertible b => 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 :: 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 =
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 :: forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
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 :: forall b c.
(BinaryConvertible b, BinaryConvertible c) =>
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 :: forall a d b c.
(HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) =>
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 :: forall b c.
(BinaryConvertible b, BinaryConvertible c) =>
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 :: 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]]
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 :: forall a b. (HVIO a, HVIO b) => 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 :: forall a. HVFSOpenable a => 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 :: forall a. HVFSOpenable a => 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