{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}

{- | Library for converting types to and from binary, so that they can
be written to and from files, stored compactly in memory, and so on.

This is a preliminary version of the library, hence I have decided
/not/ to optimise heavily, beyond putting in strictness annotations
in where they seem appropriate.

A good place to start optimising would probably be the separate
"Bytes" libary.

See also "BinaryInstances", which declares instances for the standard
types (and one or two others), "BinaryUtils", which contains
(mostly) material for declaring new instances, "BinaryExtras",
which contains other miscellaneous utilities, and finally
"BinaryAll" which just imports and reexports everything. -}
module Util.Binary (

   hWrite, -- :: HasBinary a IO => Handle -> a -> IO ()
   hRead, -- :: HasBinary a IO => Handle -> IO a

   writeToBytes, -- :: HasBinary a StateBinArea => a -> IO (Bytes,Int)
   writeToBytes0, -- :: HasBinary a StateBinArea => Int -> a -> IO (Bytes,Int)
   readFromBytes, -- :: HasBinary a StateBinArea => (Bytes,Int) -> IO a


   HasBinary (..),
   WriteBinary (..),
   ReadBinary (..),

   {- Ways of constructing WriteBinary/ReadBinary instances (not usually
   required explicitly). -}
   toWriteBinaryHandle, -- :: Handle -> WriteBinary IO
   toReadBinaryHandle, -- :: Handle -> ReadBinary IO

   -- Functions required for writing directly to binary areas.
   BinArea,
   StateBinArea, -- = StateT BinArea IO

   -- writing a BinArea

   -- create
   mkEmptyBinArea, {- :: Int -> IO BinArea
   pass as argument to writeBin -}
   writeBinaryBinArea, {- :: WriteBinary StateBinArea
   close and get contents. -}
   closeBinArea, -- :: BinArea -> IO (Bytes,Int)

   -- reading a BinArea

   -- create
   mkBinArea, {- :: (Bytes,Int) -> BinArea
   pass to things which read. -}
   readBinaryBinArea, {- :: ReadBinary StateBinArea
   check that the BinArea is completely read. -}
   checkFullBinArea, -- :: BinArea -> IO ()


   -- Functions for transforming WriteBinary/ReadBinary values.
   liftWriteBinary,
      -- :: (forall a . m a -> n a) -> WriteBinary m -> WriteBinary n
   liftReadBinary,
      -- :: (forall a . m a -> n a) -> ReadBinary m -> ReadBinary n

   ) where

-- Standard imports
import System.IO

-- GHC imports
import Control.Monad.State

-- Our imports
import Util.Bytes

{- ----------------------------------------------------------------------
The general framework
Type variable "m" is a monad; "a" is the thing to read or write.

NB.  Bytes values are currently not subject to the garbage-collector,
and so need to be explicitly freed.   The following rules for this
should be observed.

(1) For writeBytes, it is only guaranteed that the argument "Bytes"
will be valid at the actual time of evaluation.
(2) For readBytes, it is the caller's responsibility to free the returned
area.
---------------------------------------------------------------------- -}

-- | A consumer of binary data
data WriteBinary m =
   WriteBinary {
      WriteBinary m -> Byte -> m ()
writeByte :: Byte -> m (),
         -- ^ write one byte
      WriteBinary m -> Bytes -> Int -> m ()
writeBytes :: Bytes -> Int -> m ()
         -- ^ write multiple bytes
      }

-- | A source of binary data
data ReadBinary m =
   ReadBinary {
      ReadBinary m -> m Byte
readByte :: m Byte,
         -- ^ read one byte
      ReadBinary m -> Int -> m Bytes
readBytes :: Int -> m Bytes
         -- ^ read multiple bytes
      }

class HasBinary a m where
   writeBin :: WriteBinary m -> a -> m ()
      -- ^ Given a consumer of binary data, and an (a), write out the (a)
   readBin :: ReadBinary m -> m a
      -- ^ Given a source of binary data, provide an (a)

{- ----------------------------------------------------------------------
Reading/Writing HasBinary instances to Handles.
---------------------------------------------------------------------- -}

-- | Write an (a) to a 'Handle'
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


-- | Read an (a) from a '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
      }

{- ----------------------------------------------------------------------
Writing HasBinary instances to a memory area

We do this by allocating an area, and then doubling its size as
necessary.
---------------------------------------------------------------------- -}

-- | Somewhere to where you write binary data in memory.
data BinArea = BinArea {
   BinArea -> Bytes
bytes :: ! Bytes, -- current storage area
   BinArea -> Int
len :: ! Int, -- its length
   BinArea -> Int
next :: ! Int -- where to write next bit of data.
   }

-- | Write an (a) to memory.  The 'Int' is the length of the area.
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
   {- Be generous, since memory is cheap.  Make it a bit less than a power
   of two, since some memory allocation algorithms (buddy algorithm)
   like this. -}

{- | Write an (a) to memory.
The integer argument is an initial guess at the number of bytes
that will be needed.  This should be greater than 0.  If it is
too small, there will be unnecessary reallocations; if too large,
too much memory will be used. -}
writeToBytes0 :: HasBinary a StateBinArea => Int -> a -> IO (Bytes, Int)
-- The result is returned as a pair (data area,length)
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

-- | Create an empty 'BinArea', given the initial size.
mkEmptyBinArea :: Int -> IO BinArea
-- the argument gives the initial size to use (which had better be positive).
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
         }

-- | Return all the data currently in the 'BinArea'
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)

-- | a state monad containing the BinArea.
type StateBinArea = StateT BinArea IO

-- | A 'BinArea' as somewhere to put binary data.
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})
   }

-- | ensure that the given BinArea can hold at least len bytes.
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
              }

{- ----------------------------------------------------------------------
Reading Binary instances from a memory area
We use BinArea's for this too.  But this is simpler, because we don't have to
worry about reallocing.
---------------------------------------------------------------------- -}

{- | Read a value from binary data in memory.  The 'Int' is the length,
and there will be an error if this is either too small or too large. -}
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

{- | Turn binary data in memory into a 'BinArea' (so that you can
read from it). -}
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"


-- | A BinArea as a source of binary data.
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 ()
-- check that the given BinArea can hold at least len bytes.
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"

{- ----------------------------------------------------------------------
Lifting writeBinary and readBinary instances.
---------------------------------------------------------------------- -}

-- | Transform the monad used by a 'WriteBinary'
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}

-- | Transform the monad used by a 'ReadBinary'
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}