{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
module Util.Binary (
hWrite,
hRead,
writeToBytes,
writeToBytes0,
readFromBytes,
HasBinary (..),
WriteBinary (..),
ReadBinary (..),
toWriteBinaryHandle,
toReadBinaryHandle,
BinArea,
StateBinArea,
mkEmptyBinArea,
writeBinaryBinArea,
closeBinArea,
mkBinArea,
readBinaryBinArea,
checkFullBinArea,
liftWriteBinary,
liftReadBinary,
) where
import System.IO
import Control.Monad.State
import Util.Bytes
data WriteBinary m =
WriteBinary {
WriteBinary m -> Byte -> m ()
writeByte :: Byte -> m (),
WriteBinary m -> Bytes -> Int -> m ()
writeBytes :: Bytes -> Int -> m ()
}
data ReadBinary m =
ReadBinary {
ReadBinary m -> m Byte
readByte :: m Byte,
ReadBinary m -> Int -> m Bytes
readBytes :: Int -> m Bytes
}
class HasBinary a m where
writeBin :: WriteBinary m -> a -> m ()
readBin :: ReadBinary m -> m a
hWrite :: HasBinary a IO => Handle -> a -> IO ()
hWrite :: Handle -> a -> IO ()
hWrite Handle
handle = WriteBinary IO -> a -> IO ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin (WriteBinary IO -> a -> IO ()) -> WriteBinary IO -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> WriteBinary IO
toWriteBinaryHandle Handle
handle
hRead :: HasBinary a IO => Handle -> IO a
hRead :: Handle -> IO a
hRead Handle
handle = ReadBinary IO -> IO a
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin (Handle -> ReadBinary IO
toReadBinaryHandle Handle
handle)
toWriteBinaryHandle :: Handle -> WriteBinary IO
toWriteBinaryHandle :: Handle -> WriteBinary IO
toWriteBinaryHandle Handle
handle =
WriteBinary :: forall (m :: * -> *).
(Byte -> m ()) -> (Bytes -> Int -> m ()) -> WriteBinary m
WriteBinary {
writeByte :: Byte -> IO ()
writeByte = Handle -> Byte -> IO ()
hPutByte Handle
handle,
writeBytes :: Bytes -> Int -> IO ()
writeBytes = Handle -> Bytes -> Int -> IO ()
hPutBytes Handle
handle
}
toReadBinaryHandle :: Handle -> ReadBinary IO
toReadBinaryHandle :: Handle -> ReadBinary IO
toReadBinaryHandle Handle
handle =
ReadBinary :: forall (m :: * -> *). m Byte -> (Int -> m Bytes) -> ReadBinary m
ReadBinary {
readByte :: IO Byte
readByte = Handle -> IO Byte
hGetByte Handle
handle,
readBytes :: Int -> IO Bytes
readBytes = Handle -> Int -> IO Bytes
hGetBytes Handle
handle
}
data BinArea = BinArea {
BinArea -> Bytes
bytes :: ! Bytes,
BinArea -> Int
len :: ! Int,
BinArea -> Int
next :: ! Int
}
writeToBytes :: HasBinary a StateBinArea => a -> IO (Bytes, Int)
writeToBytes :: a -> IO (Bytes, Int)
writeToBytes = Int -> a -> IO (Bytes, Int)
forall a. HasBinary a StateBinArea => Int -> a -> IO (Bytes, Int)
writeToBytes0 Int
1000
writeToBytes0 :: HasBinary a StateBinArea => Int -> a -> IO (Bytes, Int)
writeToBytes0 :: Int -> a -> IO (Bytes, Int)
writeToBytes0 Int
len0 a
a =
do
BinArea
binArea0 <- Int -> IO BinArea
mkEmptyBinArea Int
len0
((), BinArea
binArea1) <- StateT BinArea IO () -> BinArea -> IO ((), BinArea)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (WriteBinary StateBinArea -> a -> StateT BinArea IO ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary StateBinArea
writeBinaryBinArea a
a) BinArea
binArea0
BinArea -> IO (Bytes, Int)
closeBinArea BinArea
binArea1
mkEmptyBinArea :: Int -> IO BinArea
mkEmptyBinArea :: Int -> IO BinArea
mkEmptyBinArea Int
l =
do
Bytes
bs <- Int -> IO Bytes
bytesMalloc Int
l
BinArea -> IO BinArea
forall (m :: * -> *) a. Monad m => a -> m a
return BinArea :: Bytes -> Int -> Int -> BinArea
BinArea {
bytes :: Bytes
bytes = Bytes
bs,
len :: Int
len = Int
l,
next :: Int
next = Int
0
}
closeBinArea :: BinArea -> IO (Bytes, Int)
closeBinArea :: BinArea -> IO (Bytes, Int)
closeBinArea BinArea
binArea =
do
let
bytes1 :: Bytes
bytes1 = BinArea -> Bytes
bytes BinArea
binArea
l :: Int
l = BinArea -> Int
next BinArea
binArea
Bytes
bytes2 <- Bytes -> Int -> IO Bytes
bytesReAlloc Bytes
bytes1 Int
l
(Bytes, Int) -> IO (Bytes, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes
bytes2, Int
l)
type StateBinArea = StateT BinArea IO
writeBinaryBinArea :: WriteBinary StateBinArea
writeBinaryBinArea :: WriteBinary StateBinArea
writeBinaryBinArea = WriteBinary :: forall (m :: * -> *).
(Byte -> m ()) -> (Bytes -> Int -> m ()) -> WriteBinary m
WriteBinary {
writeByte :: Byte -> StateT BinArea IO ()
writeByte = \ Byte
byte ->
(BinArea -> IO ((), BinArea)) -> StateT BinArea IO ()
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((BinArea -> IO ((), BinArea)) -> StateT BinArea IO ())
-> (BinArea -> IO ((), BinArea)) -> StateT BinArea IO ()
forall a b. (a -> b) -> a -> b
$ \ BinArea
binArea0 ->
do
let
next0 :: Int
next0 = BinArea -> Int
next BinArea
binArea0
next1 :: Int
next1 = Int
next0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
BinArea
binArea1 <- BinArea -> Int -> IO BinArea
ensureBinArea BinArea
binArea0 Int
next1
Byte -> Bytes -> Int -> IO ()
putByteToBytes Byte
byte (BinArea -> Bytes
bytes BinArea
binArea1) Int
next0
((), BinArea) -> IO ((), BinArea)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), BinArea
binArea1 {next :: Int
next = Int
next1})
, writeBytes :: Bytes -> Int -> StateT BinArea IO ()
writeBytes = \ Bytes
bytes' Int
l ->
(BinArea -> IO ((), BinArea)) -> StateT BinArea IO ()
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((BinArea -> IO ((), BinArea)) -> StateT BinArea IO ())
-> (BinArea -> IO ((), BinArea)) -> StateT BinArea IO ()
forall a b. (a -> b) -> a -> b
$ \ BinArea
binArea0 ->
do
let
next0 :: Int
next0 = BinArea -> Int
next BinArea
binArea0
next1 :: Int
next1 = Int
next0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l
BinArea
binArea1 <- BinArea -> Int -> IO BinArea
ensureBinArea BinArea
binArea0 Int
next1
Bytes -> Int -> Bytes -> Int -> Int -> IO ()
putBytesToBytes Bytes
bytes' Int
0 (BinArea -> Bytes
bytes BinArea
binArea1) Int
next0 Int
l
((), BinArea) -> IO ((), BinArea)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), BinArea
binArea1 {next :: Int
next = Int
next1})
}
ensureBinArea :: BinArea -> Int -> IO BinArea
ensureBinArea :: BinArea -> Int -> IO BinArea
ensureBinArea BinArea
binArea Int
size =
if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= BinArea -> Int
len BinArea
binArea
then
BinArea -> IO BinArea
forall (m :: * -> *) a. Monad m => a -> m a
return BinArea
binArea
else
do
let
len1 :: Int
len1 = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
size
Bytes
bytes1 <- Bytes -> Int -> IO Bytes
bytesReAlloc (BinArea -> Bytes
bytes BinArea
binArea) Int
len1
BinArea -> IO BinArea
forall (m :: * -> *) a. Monad m => a -> m a
return BinArea :: Bytes -> Int -> Int -> BinArea
BinArea {
bytes :: Bytes
bytes = Bytes
bytes1,
len :: Int
len = Int
len1,
next :: Int
next = BinArea -> Int
next BinArea
binArea
}
readFromBytes :: HasBinary a StateBinArea => (Bytes, Int) -> IO a
readFromBytes :: (Bytes, Int) -> IO a
readFromBytes (Bytes, Int)
bl =
do
let
binArea0 :: BinArea
binArea0 = (Bytes, Int) -> BinArea
mkBinArea (Bytes, Int)
bl
(a
a, BinArea
binArea1) <- StateT BinArea IO a -> BinArea -> IO (a, BinArea)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReadBinary StateBinArea -> StateT BinArea IO a
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary StateBinArea
readBinaryBinArea) BinArea
binArea0
BinArea -> IO ()
checkFullBinArea BinArea
binArea1
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
mkBinArea :: (Bytes, Int) -> BinArea
mkBinArea :: (Bytes, Int) -> BinArea
mkBinArea (Bytes
bytes', Int
len') =
BinArea :: Bytes -> Int -> Int -> BinArea
BinArea {
bytes :: Bytes
bytes = Bytes
bytes',
len :: Int
len = Int
len',
next :: Int
next = Int
0
}
checkFullBinArea :: BinArea -> IO ()
checkFullBinArea :: BinArea -> IO ()
checkFullBinArea BinArea
binArea =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BinArea -> Int
next BinArea
binArea Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== BinArea -> Int
len BinArea
binArea) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Binary.checkFullBinArea: mysterious extra bytes"
readBinaryBinArea :: ReadBinary StateBinArea
readBinaryBinArea :: ReadBinary StateBinArea
readBinaryBinArea = ReadBinary :: forall (m :: * -> *). m Byte -> (Int -> m Bytes) -> ReadBinary m
ReadBinary {
readByte :: StateBinArea Byte
readByte = (BinArea -> IO (Byte, BinArea)) -> StateBinArea Byte
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((BinArea -> IO (Byte, BinArea)) -> StateBinArea Byte)
-> (BinArea -> IO (Byte, BinArea)) -> StateBinArea Byte
forall a b. (a -> b) -> a -> b
$ \ BinArea
binArea0 ->
do
let
next0 :: Int
next0 = BinArea -> Int
next BinArea
binArea0
next1 :: Int
next1 = Int
next0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
BinArea -> Int -> IO ()
checkBinArea BinArea
binArea0 Int
next1
Byte
byte <- Bytes -> Int -> IO Byte
getByteFromBytes (BinArea -> Bytes
bytes BinArea
binArea0) Int
next0
(Byte, BinArea) -> IO (Byte, BinArea)
forall (m :: * -> *) a. Monad m => a -> m a
return (Byte
byte, BinArea
binArea0 {next :: Int
next = Int
next1})
, readBytes :: Int -> StateBinArea Bytes
readBytes = \ Int
l ->
(BinArea -> IO (Bytes, BinArea)) -> StateBinArea Bytes
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((BinArea -> IO (Bytes, BinArea)) -> StateBinArea Bytes)
-> (BinArea -> IO (Bytes, BinArea)) -> StateBinArea Bytes
forall a b. (a -> b) -> a -> b
$ \ BinArea
binArea0 ->
do
let
next0 :: Int
next0 = BinArea -> Int
next BinArea
binArea0
next1 :: Int
next1 = Int
next0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l
BinArea -> Int -> IO ()
checkBinArea BinArea
binArea0 Int
next1
Bytes
bytes' <- Int -> IO Bytes
bytesMalloc Int
l
Bytes -> Int -> Bytes -> Int -> Int -> IO ()
putBytesToBytes (BinArea -> Bytes
bytes BinArea
binArea0) Int
next0 Bytes
bytes' Int
0 Int
l
(Bytes, BinArea) -> IO (Bytes, BinArea)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes
bytes', BinArea
binArea0 {next :: Int
next = Int
next1})
}
checkBinArea :: BinArea -> Int -> IO ()
checkBinArea :: BinArea -> Int -> IO ()
checkBinArea BinArea
binArea Int
newNext =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newNext Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> BinArea -> Int
len BinArea
binArea) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Binary.checkBinArea - BinArea overflow on read"
liftWriteBinary :: (forall a . m a -> n a) -> WriteBinary m -> WriteBinary n
liftWriteBinary :: (forall a. m a -> n a) -> WriteBinary m -> WriteBinary n
liftWriteBinary forall a. m a -> n a
lft WriteBinary m
wb =
let
writeByte2 :: Byte -> n ()
writeByte2 Byte
b = m () -> n ()
forall a. m a -> n a
lft (WriteBinary m -> Byte -> m ()
forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte WriteBinary m
wb Byte
b)
writeBytes2 :: Bytes -> Int -> n ()
writeBytes2 Bytes
b Int
i = m () -> n ()
forall a. m a -> n a
lft (WriteBinary m -> Bytes -> Int -> m ()
forall (m :: * -> *). WriteBinary m -> Bytes -> Int -> m ()
writeBytes WriteBinary m
wb Bytes
b Int
i)
in
WriteBinary :: forall (m :: * -> *).
(Byte -> m ()) -> (Bytes -> Int -> m ()) -> WriteBinary m
WriteBinary {writeByte :: Byte -> n ()
writeByte = Byte -> n ()
writeByte2, writeBytes :: Bytes -> Int -> n ()
writeBytes = Bytes -> Int -> n ()
writeBytes2}
liftReadBinary :: (forall a . m a -> n a) -> ReadBinary m -> ReadBinary n
liftReadBinary :: (forall a. m a -> n a) -> ReadBinary m -> ReadBinary n
liftReadBinary forall a. m a -> n a
lft ReadBinary m
rb =
let
readByte2 :: n Byte
readByte2 = m Byte -> n Byte
forall a. m a -> n a
lft (ReadBinary m -> m Byte
forall (m :: * -> *). ReadBinary m -> m Byte
readByte ReadBinary m
rb)
readBytes2 :: Int -> n Bytes
readBytes2 Int
i = m Bytes -> n Bytes
forall a. m a -> n a
lft (ReadBinary m -> Int -> m Bytes
forall (m :: * -> *). ReadBinary m -> Int -> m Bytes
readBytes ReadBinary m
rb Int
i)
in
ReadBinary :: forall (m :: * -> *). m Byte -> (Int -> m Bytes) -> ReadBinary m
ReadBinary {readByte :: n Byte
readByte = n Byte
readByte2, readBytes :: Int -> n Bytes
readBytes = Int -> n Bytes
readBytes2}