{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}

-- | Instances of the 'Binary.HasBinary' class.  This includes the
-- standard types (except of course for things like function types and
-- IO) plus a few others.
module Util.BinaryInstances(
   -- Methods provided for encoding alternatives
   Choice5(..),
      -- 5-way alternatives.

   HasWrapper(..), -- class for unlimited (well, up to 256) alternatives.
      -- instance this class and you get an instance of HasBinary
   Wrapped(..),
   UnWrap(..),
   wrap0,wrap1,wrap2,wrap3,wrap4,
      -- used for instancing.

   ReadShow(..),
      -- A wrapper for things which are to be represented by their
      -- Read/Show instances.
   ViaEnum(..),
      -- A wrapper for things which are to be represented by their
      -- Enum instances.

   Unsigned(..),
      -- A wrapper for unsigned integral types.
   ) where

import Data.Char

-- GHC modules
import Control.Monad.Fail
import Data.Bits
import Data.Word
import GHC.Int(Int32)
import Foreign.C.Types

-- Our modules
import Util.Bytes
import Util.Binary
import Util.BinaryUtils

-- -----------------------------------------------------------------------
-- Encoding tuples (we go up to 5).
-- -----------------------------------------------------------------------

instance Monad m => HasBinary () m where
   writeBin :: WriteBinary m -> () -> m ()
writeBin WriteBinary m
wb () = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   readBin :: ReadBinary m -> m ()
readBin ReadBinary m
rb = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance (Monad m,HasBinary v1 m,HasBinary v2 m) => HasBinary (v1,v2) m where
   writeBin :: WriteBinary m -> (v1, v2) -> m ()
writeBin WriteBinary m
wb (v1
v1,v2
v2) =
      do
         WriteBinary m -> v1 -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v1
v1
         WriteBinary m -> v2 -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v2
v2
   readBin :: ReadBinary m -> m (v1, v2)
readBin ReadBinary m
wb =
      do
         v1
v1 <- ReadBinary m -> m v1
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
wb
         v2
v2 <- ReadBinary m -> m v2
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
wb
         (v1, v2) -> m (v1, v2)
forall (m :: * -> *) a. Monad m => a -> m a
return (v1
v1,v2
v2)

instance (Monad m,HasBinary v1 m,HasBinary (v2,v3) m)
   => HasBinary (v1,v2,v3) m where
   writeBin :: WriteBinary m -> (v1, v2, v3) -> m ()
writeBin = ((v1, v2, v3) -> (v1, (v2, v3)))
-> WriteBinary m -> (v1, v2, v3) -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (v1
v1,v2
v2,v3
v3) -> (v1
v1,(v2
v2,v3
v3)))
   readBin :: ReadBinary m -> m (v1, v2, v3)
readBin = ((v1, (v2, v3)) -> (v1, v2, v3)) -> ReadBinary m -> m (v1, v2, v3)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (v1
v1,(v2
v2,v3
v3)) -> (v1
v1,v2
v2,v3
v3))

instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4) m)
   => HasBinary (v1,v2,v3,v4) m where
   writeBin :: WriteBinary m -> (v1, v2, v3, v4) -> m ()
writeBin = ((v1, v2, v3, v4) -> (v1, (v2, v3, v4)))
-> WriteBinary m -> (v1, v2, v3, v4) -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (v1
v1,v2
v2,v3
v3,v4
v4) -> (v1
v1,(v2
v2,v3
v3,v4
v4)))
   readBin :: ReadBinary m -> m (v1, v2, v3, v4)
readBin = ((v1, (v2, v3, v4)) -> (v1, v2, v3, v4))
-> ReadBinary m -> m (v1, v2, v3, v4)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (v1
v1,(v2
v2,v3
v3,v4
v4)) -> (v1
v1,v2
v2,v3
v3,v4
v4))

instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4,v5) m)
   => HasBinary (v1,v2,v3,v4,v5) m where
   writeBin :: WriteBinary m -> (v1, v2, v3, v4, v5) -> m ()
writeBin = ((v1, v2, v3, v4, v5) -> (v1, (v2, v3, v4, v5)))
-> WriteBinary m -> (v1, v2, v3, v4, v5) -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (v1
v1,v2
v2,v3
v3,v4
v4,v5
v5) -> (v1
v1,(v2
v2,v3
v3,v4
v4,v5
v5)))
   readBin :: ReadBinary m -> m (v1, v2, v3, v4, v5)
readBin = ((v1, (v2, v3, v4, v5)) -> (v1, v2, v3, v4, v5))
-> ReadBinary m -> m (v1, v2, v3, v4, v5)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (v1
v1,(v2
v2,v3
v3,v4
v4,v5
v5)) -> (v1
v1,v2
v2,v3
v3,v4
v4,v5
v5))

instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4,v5,v6) m)
   => HasBinary (v1,v2,v3,v4,v5,v6) m where
   writeBin :: WriteBinary m -> (v1, v2, v3, v4, v5, v6) -> m ()
writeBin = ((v1, v2, v3, v4, v5, v6) -> (v1, (v2, v3, v4, v5, v6)))
-> WriteBinary m -> (v1, v2, v3, v4, v5, v6) -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (v1
v1,v2
v2,v3
v3,v4
v4,v5
v5,v6
v6) -> (v1
v1,(v2
v2,v3
v3,v4
v4,v5
v5,v6
v6)))
   readBin :: ReadBinary m -> m (v1, v2, v3, v4, v5, v6)
readBin = ((v1, (v2, v3, v4, v5, v6)) -> (v1, v2, v3, v4, v5, v6))
-> ReadBinary m -> m (v1, v2, v3, v4, v5, v6)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (v1
v1,(v2
v2,v3
v3,v4
v4,v5
v5,v6
v6)) -> (v1
v1,v2
v2,v3
v3,v4
v4,v5
v5,v6
v6))


instance (Monad m,HasBinary v1 m,HasBinary (v2,v3,v4,v5,v6,v7) m)
   => HasBinary (v1,v2,v3,v4,v5,v6,v7) m where
   writeBin :: WriteBinary m -> (v1, v2, v3, v4, v5, v6, v7) -> m ()
writeBin = ((v1, v2, v3, v4, v5, v6, v7) -> (v1, (v2, v3, v4, v5, v6, v7)))
-> WriteBinary m -> (v1, v2, v3, v4, v5, v6, v7) -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (v1
v1,v2
v2,v3
v3,v4
v4,v5
v5,v6
v6,v7
v7) -> (v1
v1,(v2
v2,v3
v3,v4
v4,v5
v5,v6
v6,v7
v7)))
   readBin :: ReadBinary m -> m (v1, v2, v3, v4, v5, v6, v7)
readBin = ((v1, (v2, v3, v4, v5, v6, v7)) -> (v1, v2, v3, v4, v5, v6, v7))
-> ReadBinary m -> m (v1, v2, v3, v4, v5, v6, v7)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (v1
v1,(v2
v2,v3
v3,v4
v4,v5
v5,v6
v6,v7
v7)) -> (v1
v1,v2
v2,v3
v3,v4
v4,v5
v5,v6
v6,v7
v7))

-- -----------------------------------------------------------------------
-- Encoding Byte and (Bytes,Int).
-- NB.  We assume that the (Int) is non-negative!!!
-- -----------------------------------------------------------------------

instance HasBinary Byte m where
   writeBin :: WriteBinary m -> Byte -> m ()
writeBin WriteBinary m
wb Byte
byte = WriteBinary m -> Byte -> m ()
forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte WriteBinary m
wb Byte
byte
   readBin :: ReadBinary m -> m Byte
readBin ReadBinary m
wb = ReadBinary m -> m Byte
forall (m :: * -> *). ReadBinary m -> m Byte
readByte ReadBinary m
wb

instance Monad m => HasBinary (Bytes,Int) m where
   writeBin :: WriteBinary m -> (Bytes, Int) -> m ()
writeBin WriteBinary m
wb (Bytes
bytes,Int
len) =
      do
         WriteBinary m -> Word -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb ( (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) :: Word)
         WriteBinary m -> Bytes -> Int -> m ()
forall (m :: * -> *). WriteBinary m -> Bytes -> Int -> m ()
writeBytes WriteBinary m
wb Bytes
bytes Int
len
   readBin :: ReadBinary m -> m (Bytes, Int)
readBin ReadBinary m
wb =
      do
         (Word
lenW :: Word) <- ReadBinary m -> m Word
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
wb
         let
            len :: Int
len = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
lenW
         Bytes
bytes <- ReadBinary m -> Int -> m Bytes
forall (m :: * -> *). ReadBinary m -> Int -> m Bytes
readBytes ReadBinary m
wb Int
len
         (Bytes, Int) -> m (Bytes, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes
bytes,Int
len)

-- -----------------------------------------------------------------------
-- Encoding Either/Maybe/Bool
-- -----------------------------------------------------------------------

instance (Monad m,HasBinary a m) => HasBinary (Maybe a) m where
   writeBin :: WriteBinary m -> Maybe a -> m ()
writeBin = (Maybe a -> Either () a) -> WriteBinary m -> Maybe a -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ Maybe a
aOpt -> case Maybe a
aOpt of
      Maybe a
Nothing -> () -> Either () a
forall a b. a -> Either a b
Left ()
      Just a
a -> a -> Either () a
forall a b. b -> Either a b
Right a
a
      )
   readBin :: ReadBinary m -> m (Maybe a)
readBin = (Either () a -> Maybe a) -> ReadBinary m -> m (Maybe a)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ Either () a
aEither -> case Either () a
aEither of
      Left () -> Maybe a
forall a. Maybe a
Nothing
      Right a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
     )

instance (Monad m,HasBinary a m,HasBinary b m)
   => HasBinary (Either a b) m where

   writeBin :: WriteBinary m -> Either a b -> m ()
writeBin WriteBinary m
wb (Left a
a) =
      do
         WriteBinary m -> Bool -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb Bool
False
         WriteBinary m -> a -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb a
a
   writeBin WriteBinary m
wb (Right b
b) =
      do
         WriteBinary m -> Bool -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb Bool
True
         WriteBinary m -> b -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb b
b
   readBin :: ReadBinary m -> m (Either a b)
readBin ReadBinary m
rb =
      do
         Bool
isRight <- ReadBinary m -> m Bool
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
         if Bool
isRight
            then
               do
                  b
b <- ReadBinary m -> m b
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                  Either a b -> m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either a b
forall a b. b -> Either a b
Right b
b)
            else
               do
                  a
a <- ReadBinary m -> m a
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                  Either a b -> m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a b
forall a b. a -> Either a b
Left a
a)


instance Monad m => HasBinary Bool m where
   writeBin :: WriteBinary m -> Bool -> m ()
writeBin = (Bool -> Byte) -> WriteBinary m -> Bool -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ Bool
b -> if Bool
b then (Byte
1 :: Byte) else Byte
0)
   readBin :: ReadBinary m -> m Bool
readBin ReadBinary m
rb =
      do
         (Byte
switch :: Byte) <- ReadBinary m -> m Byte
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
         case Byte
switch of
            Byte
0 -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Byte
1 -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Byte
_ -> [Char] -> m Bool
forall a. HasCallStack => [Char] -> a
error ([Char]
"BinaryInstances.Bool - unexpected switch "
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Byte -> [Char]
forall a. Show a => a -> [Char]
show Byte
switch)


-- -----------------------------------------------------------------------
-- Encoding Char (yes, we do Unicode, although this costs us)
-- -----------------------------------------------------------------------

instance Monad m => HasBinary Char m where
   writeBin :: WriteBinary m -> Char -> m ()
writeBin = (Char -> Word) -> WriteBinary m -> Char -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ Char
c -> (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> (Char -> Int) -> Char -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Word) -> Char -> Word
forall a b. (a -> b) -> a -> b
$ Char
c) :: Word)
   readBin :: ReadBinary m -> m Char
readBin = (Word -> Char) -> ReadBinary m -> m Char
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (Word
w :: Word) -> Int -> Char
chr (Int -> Char) -> (Word -> Int) -> Word -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Char) -> Word -> Char
forall a b. (a -> b) -> a -> b
$ Word
w)

-- -----------------------------------------------------------------------
-- Encoding lists
-- -----------------------------------------------------------------------

instance (Monad m,HasBinary a m) => HasBinary [a] m where
   writeBin :: WriteBinary m -> [a] -> m ()
writeBin WriteBinary m
wb [a]
as =
      do
         WriteBinary m -> Word -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as) :: Word)
         (a -> m ()) -> [a] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ a
a -> WriteBinary m -> a -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb a
a) [a]
as
   readBin :: ReadBinary m -> m [a]
readBin ReadBinary m
wb =
      do
         (Word
len :: Word)<- ReadBinary m -> m Word
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
wb
         [a]
as <- (Word -> m a) -> [Word] -> m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Word
_ -> ReadBinary m -> m a
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
wb) [Word
1..Word
len]
         [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
as


-- -----------------------------------------------------------------------
-- Encoding integers
-- Some features of our encoding.
-- (1) integers have the same encoding and words have the same encoding,
--     however the two encodings differ slightly, since words don't have
--     to store the sign.  This is important since it means ASCII characters
--     can be stored in one byte (they go via word).
-- (1) it is independent of the sort of integer in question.
-- (2) it is variable size, so that small integers (which are rather common)
-- fit into one byte.
-- -----------------------------------------------------------------------

instance Monad m => HasBinary Int m where
   writeBin :: WriteBinary m -> Int -> m ()
writeBin = (Int -> CodedList) -> WriteBinary m -> Int -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite Int -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeIntegral
   readBin :: ReadBinary m -> m Int
readBin = (CodedList -> Int) -> ReadBinary m -> m Int
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead CodedList -> Int
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeIntegral

instance Monad m => HasBinary Word m where
   writeBin :: WriteBinary m -> Word -> m ()
writeBin = (Word -> CodedList) -> WriteBinary m -> Word -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite Word -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeWord
   readBin :: ReadBinary m -> m Word
readBin = (CodedList -> Word) -> ReadBinary m -> m Word
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead CodedList -> Word
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeWord

instance Monad m => HasBinary Int32 m where
   writeBin :: WriteBinary m -> Int32 -> m ()
writeBin = (Int32 -> CodedList) -> WriteBinary m -> Int32 -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite Int32 -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeIntegral
   readBin :: ReadBinary m -> m Int32
readBin = (CodedList -> Int32) -> ReadBinary m -> m Int32
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead CodedList -> Int32
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeIntegral

instance Monad m => HasBinary Word32 m where
   writeBin :: WriteBinary m -> Word32 -> m ()
writeBin = (Word32 -> CodedList) -> WriteBinary m -> Word32 -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite Word32 -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeWord
   readBin :: ReadBinary m -> m Word32
readBin = (CodedList -> Word32) -> ReadBinary m -> m Word32
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead CodedList -> Word32
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeWord

instance Monad m => HasBinary Integer m where
   writeBin :: WriteBinary m -> Integer -> m ()
writeBin = (Integer -> CodedList) -> WriteBinary m -> Integer -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite Integer -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeIntegral
   readBin :: ReadBinary m -> m Integer
readBin = (CodedList -> Integer) -> ReadBinary m -> m Integer
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead CodedList -> Integer
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeIntegral

instance Monad m => HasBinary CSize m where
   writeBin :: WriteBinary m -> CSize -> m ()
writeBin = (CSize -> CodedList) -> WriteBinary m -> CSize -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite CSize -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeWord
   readBin :: ReadBinary m -> m CSize
readBin = (CodedList -> CSize) -> ReadBinary m -> m CSize
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead CodedList -> CSize
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeWord

encodeIntegral :: (Integral integral,Bits integral) => integral -> CodedList
encodeIntegral :: integral -> CodedList
encodeIntegral (integral
i :: integral) =
   if integral -> Bool
isLarge integral
i
      then
         let
            lowestPart :: integral
lowestPart = integral
i integral -> integral -> integral
forall a. Bits a => a -> a -> a
.&. integral
forall integral. (Integral integral, Bits integral) => integral
mask
            highPart :: integral
highPart = integral
i integral -> Int -> integral
forall a. Bits a => a -> Int -> a
`shiftR` Int
bitsPerByte
            CodedList [Byte]
codedHigh = integral -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeIntegral integral
highPart
         in
            [Byte] -> CodedList
CodedList ((integral -> Byte
forall a b. (Integral a, Num b) => a -> b
fromIntegral integral
lowestPart) Byte -> [Byte] -> [Byte]
forall a. a -> [a] -> [a]
: [Byte]
codedHigh)
      else
         let
            wrapped :: integral
wrapped =
               if integral
i integral -> integral -> Bool
forall a. Ord a => a -> a -> Bool
< integral
0
                  then
                     integral
forall integral. Bits integral => integral
topBit integral -> integral -> integral
forall a. Num a => a -> a -> a
+ integral
i
                  else
                     integral
i
         in
            [Byte] -> CodedList
CodedList [integral -> Byte
forall a b. (Integral a, Num b) => a -> b
fromIntegral integral
wrapped]
   where
      isLarge :: integral -> Bool
      isLarge :: integral -> Bool
isLarge = (\ integral
i -> (integral
i integral -> integral -> Bool
forall a. Ord a => a -> a -> Bool
>= integral
forall integral. Bits integral => integral
nextBit) Bool -> Bool -> Bool
|| (integral
i integral -> integral -> Bool
forall a. Ord a => a -> a -> Bool
< -integral
forall integral. Bits integral => integral
nextBit))


decodeIntegral :: (Integral integral,Bits integral) => CodedList -> integral
decodeIntegral :: CodedList -> integral
decodeIntegral (CodedList []) = [Char] -> integral
forall a. HasCallStack => [Char] -> a
error [Char]
"empty CodedList"
decodeIntegral (CodedList [Byte
wpped]) =
   let
      wrapped :: integral
wrapped = Byte -> integral
forall a b. (Integral a, Num b) => a -> b
fromIntegral Byte
wpped
   in
      if integral
wrapped integral -> integral -> Bool
forall a. Ord a => a -> a -> Bool
>= integral
forall integral. Bits integral => integral
nextBit
         then
            integral
wrapped integral -> integral -> integral
forall a. Num a => a -> a -> a
- integral
forall integral. Bits integral => integral
topBit
         else
            integral
wrapped
decodeIntegral (CodedList (Byte
lPart : [Byte]
codedHigh)) =
   let
      lowestPart :: integral
lowestPart = Byte -> integral
forall a b. (Integral a, Num b) => a -> b
fromIntegral Byte
lPart
      highPart :: integral
highPart = CodedList -> integral
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeIntegral ([Byte] -> CodedList
CodedList [Byte]
codedHigh)
   in
      integral
lowestPart integral -> integral -> integral
forall a. Num a => a -> a -> a
+ (integral
highPart integral -> Int -> integral
forall a. Bits a => a -> Int -> a
`shiftL` Int
bitsPerByte)

encodeWord :: (Integral integral,Bits integral) => integral -> CodedList
encodeWord :: integral -> CodedList
encodeWord (integral
i :: integral) =
   if integral -> Bool
isLarge integral
i
      then
         let
            lowestPart :: integral
lowestPart = integral
i integral -> integral -> integral
forall a. Bits a => a -> a -> a
.&. integral
forall integral. (Integral integral, Bits integral) => integral
mask
            highPart :: integral
highPart = integral
i integral -> Int -> integral
forall a. Bits a => a -> Int -> a
`shiftR` Int
bitsPerByte
            CodedList [Byte]
codedHigh = integral -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeWord integral
highPart
         in
            [Byte] -> CodedList
CodedList ((integral -> Byte
forall a b. (Integral a, Num b) => a -> b
fromIntegral integral
lowestPart) Byte -> [Byte] -> [Byte]
forall a. a -> [a] -> [a]
: [Byte]
codedHigh)
      else
         let
            wrapped :: integral
wrapped = integral
i
         in
            [Byte] -> CodedList
CodedList [integral -> Byte
forall a b. (Integral a, Num b) => a -> b
fromIntegral integral
wrapped]
   where
      isLarge :: integral -> Bool
      isLarge :: integral -> Bool
isLarge = (\ integral
i -> integral
i integral -> integral -> Bool
forall a. Ord a => a -> a -> Bool
>= integral
forall integral. Bits integral => integral
topBit)

decodeWord :: (Integral integral,Bits integral) => CodedList -> integral
decodeWord :: CodedList -> integral
decodeWord (CodedList []) = [Char] -> integral
forall a. HasCallStack => [Char] -> a
error [Char]
"empty CodedList2"
decodeWord (CodedList [Byte
wpped]) =
   let
      wrapped :: integral
wrapped = Byte -> integral
forall a b. (Integral a, Num b) => a -> b
fromIntegral Byte
wpped
   in
      integral
wrapped
decodeWord (CodedList (Byte
lPart : [Byte]
codedHigh)) =
   let
      lowestPart :: integral
lowestPart = Byte -> integral
forall a b. (Integral a, Num b) => a -> b
fromIntegral Byte
lPart
      highPart :: integral
highPart = CodedList -> integral
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeWord ([Byte] -> CodedList
CodedList [Byte]
codedHigh)
   in
      integral
lowestPart integral -> integral -> integral
forall a. Num a => a -> a -> a
+ (integral
highPart integral -> Int -> integral
forall a. Bits a => a -> Int -> a
`shiftL` Int
bitsPerByte)

-- -----------------------------------------------------------------------
-- We make the word encoding (which is slightly more efficient for
-- unsigned integers) available via the Unsigned type.
-- -----------------------------------------------------------------------

-- | This is an @newtype@ alias for integral types where the user promises
-- that the value will be non-negative, and so saves us a bit.
-- This is what we use for character data incidentally, so that
-- ASCII characters with codes <128 can be encoded (as themselves) in
-- just one byte.
newtype Unsigned integral = Unsigned integral

instance (Monad m,Integral integral,Bits integral)
   => HasBinary (Unsigned integral) m where

   writeBin :: WriteBinary m -> Unsigned integral -> m ()
writeBin = (Unsigned integral -> CodedList)
-> WriteBinary m -> Unsigned integral -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (Unsigned integral
i) -> integral -> CodedList
forall integral.
(Integral integral, Bits integral) =>
integral -> CodedList
encodeWord integral
i)
   readBin :: ReadBinary m -> m (Unsigned integral)
readBin = (CodedList -> Unsigned integral)
-> ReadBinary m -> m (Unsigned integral)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ CodedList
i -> integral -> Unsigned integral
forall integral. integral -> Unsigned integral
Unsigned (CodedList -> integral
forall integral.
(Integral integral, Bits integral) =>
CodedList -> integral
decodeWord CodedList
i))

-- -----------------------------------------------------------------------
-- Bit constants
-- -----------------------------------------------------------------------

bitsInByte :: Int
-- Number of bits stored in a byte.  (
bitsInByte :: Int
bitsInByte = Int
8

bitsPerByte :: Int
-- Number of bits of an integer we will store per char.
-- (The remaining one is used to mark the end of the sequence.)
bitsPerByte :: Int
bitsPerByte = Int
bitsInByte Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-- Here are some useful abbreviations in this connection
topBit :: Bits integral => integral
topBit :: integral
topBit = Int -> integral
forall a. Bits a => Int -> a
bit Int
bitsPerByte

mask :: (Integral integral,Bits integral) => integral
mask :: integral
mask = integral
forall integral. Bits integral => integral
topBit integral -> integral -> integral
forall a. Num a => a -> a -> a
- integral
1

nextBit :: Bits integral => integral
nextBit :: integral
nextBit = Int -> integral
forall a. Bits a => Int -> a
bit (Int
bitsInByte Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)

-- -----------------------------------------------------------------------
-- CodedList's.  These are used as an intermediate stage to integers.
-- -----------------------------------------------------------------------


newtype CodedList = CodedList [Byte]
-- This is a nonempty list of integers in [0,2^(bitsInByte-1)).
-- We code them by setting the top bit of all but the last item.

instance Monad m => HasBinary CodedList m where
   writeBin :: WriteBinary m -> CodedList -> m ()
writeBin WriteBinary m
_ (CodedList []) = [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"empty CodedList3"
   writeBin (WriteBinary {writeByte :: forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte = Byte -> m ()
writeByte}) (CodedList [Byte
b]) =
      Byte -> m ()
writeByte Byte
b
   writeBin (wb :: WriteBinary m
wb @ WriteBinary {writeByte :: forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte = Byte -> m ()
writeByte}) (CodedList (Byte
b:[Byte]
bs)) =
      do
         Byte -> m ()
writeByte (Byte
b Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.|. Byte
forall integral. Bits integral => integral
topBit)
         WriteBinary m -> CodedList -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb ([Byte] -> CodedList
CodedList [Byte]
bs)

   readBin :: ReadBinary m -> m CodedList
readBin (rb :: ReadBinary m
rb @ ReadBinary {readByte :: forall (m :: * -> *). ReadBinary m -> m Byte
readByte = m Byte
readByte}) =
      do
         Byte
b <- m Byte
readByte
         if Byte
b Byte -> Byte -> Bool
forall a. Ord a => a -> a -> Bool
< Byte
forall integral. Bits integral => integral
topBit
            then
               CodedList -> m CodedList
forall (m :: * -> *) a. Monad m => a -> m a
return ([Byte] -> CodedList
CodedList [Byte
b])
            else
               do
                  (CodedList [Byte]
bs) <- ReadBinary m -> m CodedList
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                  CodedList -> m CodedList
forall (m :: * -> *) a. Monad m => a -> m a
return ([Byte] -> CodedList
CodedList ( (Byte
b Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
`xor` Byte
forall integral. Bits integral => integral
topBit) Byte -> [Byte] -> [Byte]
forall a. a -> [a] -> [a]
:[Byte]
bs))


-- ----------------------------------------------------------------------
-- 5-way choices.  This is probably a bit clumsier than the HasWrapper
-- method (see next section), on the other hand perhaps a bit more
-- efficient for up to 5 alternatives, since decoding doesn't have to
-- hunt through the wraps list.
-- ----------------------------------------------------------------------

-- | This is a rather inelegant way of encoding a type with up to
-- 5 alternatives.  If 5 is too many, use () for the others, if too
-- few use 'HasWrapper'.  In fact 'HasWrapper' is probably better
-- anyway.
data Choice5 v1 v2 v3 v4 v5 =
      Choice1 v1
   |  Choice2 v2
   |  Choice3 v3
   |  Choice4 v4
   |  Choice5 v5 deriving (Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool
(Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool)
-> (Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool)
-> Eq (Choice5 v1 v2 v3 v4 v5)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v1 v2 v3 v4 v5.
(Eq v1, Eq v2, Eq v3, Eq v4, Eq v5) =>
Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool
/= :: Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool
$c/= :: forall v1 v2 v3 v4 v5.
(Eq v1, Eq v2, Eq v3, Eq v4, Eq v5) =>
Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool
== :: Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool
$c== :: forall v1 v2 v3 v4 v5.
(Eq v1, Eq v2, Eq v3, Eq v4, Eq v5) =>
Choice5 v1 v2 v3 v4 v5 -> Choice5 v1 v2 v3 v4 v5 -> Bool
Eq)

instance (Monad m,
   HasBinary v1 m,HasBinary v2 m,HasBinary v3 m,HasBinary v4 m,HasBinary v5 m)
   => HasBinary (Choice5 v1 v2 v3 v4 v5) m
   where

   writeBin :: WriteBinary m -> Choice5 v1 v2 v3 v4 v5 -> m ()
writeBin WriteBinary m
wb (Choice1 v1
v) =
      do
         WriteBinary m -> Byte -> m ()
forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte WriteBinary m
wb Byte
1
         WriteBinary m -> v1 -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v1
v
   writeBin WriteBinary m
wb (Choice2 v2
v) =
      do
         WriteBinary m -> Byte -> m ()
forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte WriteBinary m
wb Byte
2
         WriteBinary m -> v2 -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v2
v
   writeBin WriteBinary m
wb (Choice3 v3
v) =
      do
         WriteBinary m -> Byte -> m ()
forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte WriteBinary m
wb Byte
3
         WriteBinary m -> v3 -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v3
v
   writeBin WriteBinary m
wb (Choice4 v4
v) =
      do
         WriteBinary m -> Byte -> m ()
forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte WriteBinary m
wb Byte
4
         WriteBinary m -> v4 -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v4
v
   writeBin WriteBinary m
wb (Choice5 v5
v) =
      do
         WriteBinary m -> Byte -> m ()
forall (m :: * -> *). WriteBinary m -> Byte -> m ()
writeByte WriteBinary m
wb Byte
5
         WriteBinary m -> v5 -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb v5
v

   readBin :: ReadBinary m -> m (Choice5 v1 v2 v3 v4 v5)
readBin ReadBinary m
rb =
      do
         Byte
switch <- ReadBinary m -> m Byte
forall (m :: * -> *). ReadBinary m -> m Byte
readByte ReadBinary m
rb
         case Byte
switch of
            Byte
1 ->
                do
                   v1
v <- ReadBinary m -> m v1
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                   Choice5 v1 v2 v3 v4 v5 -> m (Choice5 v1 v2 v3 v4 v5)
forall (m :: * -> *) a. Monad m => a -> m a
return (v1 -> Choice5 v1 v2 v3 v4 v5
forall v1 v2 v3 v4 v5. v1 -> Choice5 v1 v2 v3 v4 v5
Choice1 v1
v)
            Byte
2 ->
                do
                   v2
v <- ReadBinary m -> m v2
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                   Choice5 v1 v2 v3 v4 v5 -> m (Choice5 v1 v2 v3 v4 v5)
forall (m :: * -> *) a. Monad m => a -> m a
return (v2 -> Choice5 v1 v2 v3 v4 v5
forall v1 v2 v3 v4 v5. v2 -> Choice5 v1 v2 v3 v4 v5
Choice2 v2
v)
            Byte
3 ->
                do
                   v3
v <- ReadBinary m -> m v3
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                   Choice5 v1 v2 v3 v4 v5 -> m (Choice5 v1 v2 v3 v4 v5)
forall (m :: * -> *) a. Monad m => a -> m a
return (v3 -> Choice5 v1 v2 v3 v4 v5
forall v1 v2 v3 v4 v5. v3 -> Choice5 v1 v2 v3 v4 v5
Choice3 v3
v)
            Byte
4 ->
                do
                   v4
v <- ReadBinary m -> m v4
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                   Choice5 v1 v2 v3 v4 v5 -> m (Choice5 v1 v2 v3 v4 v5)
forall (m :: * -> *) a. Monad m => a -> m a
return (v4 -> Choice5 v1 v2 v3 v4 v5
forall v1 v2 v3 v4 v5. v4 -> Choice5 v1 v2 v3 v4 v5
Choice4 v4
v)
            Byte
5 ->
                do
                   v5
v <- ReadBinary m -> m v5
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                   Choice5 v1 v2 v3 v4 v5 -> m (Choice5 v1 v2 v3 v4 v5)
forall (m :: * -> *) a. Monad m => a -> m a
return (v5 -> Choice5 v1 v2 v3 v4 v5
forall v1 v2 v3 v4 v5. v5 -> Choice5 v1 v2 v3 v4 v5
Choice5 v5
v)
            Byte
_ -> [Char] -> m (Choice5 v1 v2 v3 v4 v5)
forall a. HasCallStack => [Char] -> a
error ([Char]
"BinaryInstances.Choice5 - unexpected switch "
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Byte -> [Char]
forall a. Show a => a -> [Char]
show Byte
switch)

-- ----------------------------------------------------------------------
-- convenient (if inefficient) way of encoding algebraic datatypes.
-- ----------------------------------------------------------------------

-- | A class allowing you to handle types with up to 256 alternatives.
-- If this all seems to complicated, look at the source file and
-- the example for the \"Tree\" data type.
class HasWrapper wrapper m where
   wraps :: [Wrap wrapper m]
      -- ^ For each alternative in the type, provide a recognition
      -- 'Byte', and a way of mapping that alternative to the (wrapper)
   unWrap :: wrapper -> UnWrap m
      -- ^ Map a (wrapper) to the corresponding recognition 'Byte'
      -- and the type within the alternative.


-- | Newtype alias you need to wrap around something which instances
-- 'HasWrapper' to get an actual HasBinary instance.  You will then
-- need something like this:
--
-- > instance Monad m => HasBinary a m where
-- >   writeBin = mapWrite Wrapped
-- >   readBin = mapRead wrapped
--
newtype Wrapped a = Wrapped {Wrapped a -> a
wrapped :: a}

-- | Value the 'HasWrapper' instance generates from 'unWrap' to
-- indicate how we should write some value to binary.
data UnWrap m = forall val . HasBinary val m
   => UnWrap
      Byte --  label for this type on writing.
      val --  value inside this wrapped type.

-- | Some alternative the user provides in 'wraps' in the
-- 'HasWrapper' instance, to indicate one particular alternative we use
-- when reading from binary.
data Wrap wrapper m = forall val . HasBinary val m
   => Wrap
      Byte --  label for this type on reading.  This must, of course, be the
           -- same as for the corresponding UnWrap.
      (val -> wrapper)
           --  how to wrap this sort of value.

-- some abbreviations for construtor functions with varying numbers of
-- arguments.

-- | 'Wrap' value for constructor with no arguments.
wrap0 :: Monad m => Byte -> wrapper -> Wrap wrapper m
wrap0 :: Byte -> wrapper -> Wrap wrapper m
wrap0 Byte
label wrapper
wrapper = Byte -> (() -> wrapper) -> Wrap wrapper m
forall wrapper (m :: * -> *) val.
HasBinary val m =>
Byte -> (val -> wrapper) -> Wrap wrapper m
Wrap Byte
label (\ () -> wrapper
wrapper)


-- | 'Wrap' value for constructor with 1 argument.
wrap1 :: HasBinary val m => Byte -> (val -> wrapper) -> Wrap wrapper m
wrap1 :: Byte -> (val -> wrapper) -> Wrap wrapper m
wrap1 = Byte -> (val -> wrapper) -> Wrap wrapper m
forall wrapper (m :: * -> *) val.
HasBinary val m =>
Byte -> (val -> wrapper) -> Wrap wrapper m
Wrap


-- | 'Wrap' value for constructor with 2 arguments.
wrap2 :: (HasBinary (val1,val2) m) => Byte
   -> (val1 -> val2 -> wrapper) -> Wrap wrapper m
wrap2 :: Byte -> (val1 -> val2 -> wrapper) -> Wrap wrapper m
wrap2 Byte
char val1 -> val2 -> wrapper
con = Byte -> ((val1, val2) -> wrapper) -> Wrap wrapper m
forall wrapper (m :: * -> *) val.
HasBinary val m =>
Byte -> (val -> wrapper) -> Wrap wrapper m
Wrap Byte
char (\ (val1
val1,val2
val2) -> val1 -> val2 -> wrapper
con val1
val1 val2
val2)


-- | 'Wrap' value for constructor with 3 arguments.
wrap3 :: (HasBinary (val1,val2,val3) m) => Byte
   -> (val1 -> val2 -> val3 -> wrapper) -> Wrap wrapper m
wrap3 :: Byte -> (val1 -> val2 -> val3 -> wrapper) -> Wrap wrapper m
wrap3 Byte
char val1 -> val2 -> val3 -> wrapper
con = Byte -> ((val1, val2, val3) -> wrapper) -> Wrap wrapper m
forall wrapper (m :: * -> *) val.
HasBinary val m =>
Byte -> (val -> wrapper) -> Wrap wrapper m
Wrap Byte
char (\ (val1
val1,val2
val2,val3
val3) -> val1 -> val2 -> val3 -> wrapper
con val1
val1 val2
val2 val3
val3)

-- | 'Wrap' value for constructor with 4 arguments.
wrap4 :: (HasBinary (val1,val2,val3,val4) m)
   => Byte -> (val1 -> val2 -> val3 -> val4 -> wrapper) -> Wrap wrapper m
wrap4 :: Byte -> (val1 -> val2 -> val3 -> val4 -> wrapper) -> Wrap wrapper m
wrap4 Byte
char val1 -> val2 -> val3 -> val4 -> wrapper
con = Byte -> ((val1, val2, val3, val4) -> wrapper) -> Wrap wrapper m
forall wrapper (m :: * -> *) val.
HasBinary val m =>
Byte -> (val -> wrapper) -> Wrap wrapper m
Wrap Byte
char (\ (val1
val1,val2
val2,val3
val3,val4
val4) -> val1 -> val2 -> val3 -> val4 -> wrapper
con val1
val1 val2
val2 val3
val3 val4
val4)

instance (Monad m,HasWrapper wrapper m) => HasBinary (Wrapped wrapper) m where
   writeBin :: WriteBinary m -> Wrapped wrapper -> m ()
writeBin WriteBinary m
wb (Wrapped wrapper
wrapper) = UnWrap m -> m ()
writeBin' (wrapper -> UnWrap m
forall wrapper (m :: * -> *).
HasWrapper wrapper m =>
wrapper -> UnWrap m
unWrap wrapper
wrapper)
      where
         writeBin' :: UnWrap m -> m ()
         writeBin' :: UnWrap m -> m ()
writeBin' (UnWrap Byte
label val
val) =
            do
               WriteBinary m -> Byte -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb Byte
label
               WriteBinary m -> val -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb val
val

   readBin :: ReadBinary m -> m (Wrapped wrapper)
readBin ReadBinary m
rb =
      do
         Byte
thisLabel <- ReadBinary m -> m Byte
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
         let
            innerWrap :: HasBinary v m => (v -> wrapper) -> m (Wrapped wrapper)
            innerWrap :: (v -> wrapper) -> m (Wrapped wrapper)
innerWrap v -> wrapper
wrapFn =
               do
                  v
val <- ReadBinary m -> m v
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
                  Wrapped wrapper -> m (Wrapped wrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (wrapper -> Wrapped wrapper
forall a. a -> Wrapped a
Wrapped (v -> wrapper
wrapFn v
val))

         case (Wrap wrapper m -> Maybe (m (Wrapped wrapper)))
-> [Wrap wrapper m] -> Maybe (m (Wrapped wrapper))
forall a b. (a -> Maybe b) -> [a] -> Maybe b
findJust
            (\ (Wrap Byte
label val -> wrapper
wrapFn :: Wrap wrapper m) ->
               if Byte
label Byte -> Byte -> Bool
forall a. Eq a => a -> a -> Bool
== Byte
thisLabel then m (Wrapped wrapper) -> Maybe (m (Wrapped wrapper))
forall a. a -> Maybe a
Just ((val -> wrapper) -> m (Wrapped wrapper)
forall v. HasBinary v m => (v -> wrapper) -> m (Wrapped wrapper)
innerWrap val -> wrapper
wrapFn) else Maybe (m (Wrapped wrapper))
forall a. Maybe a
Nothing
               )
            ([Wrap wrapper m]
forall wrapper (m :: * -> *).
HasWrapper wrapper m =>
[Wrap wrapper m]
wraps :: [Wrap wrapper m]) of

            Maybe (m (Wrapped wrapper))
Nothing -> [Char] -> m (Wrapped wrapper)
forall a. HasCallStack => [Char] -> a
error ([Char]
"BinaryInstances.Wrapper - bad switch "
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Byte -> [Char]
forall a. Show a => a -> [Char]
show Byte
thisLabel)
            Just (m (Wrapped wrapper)
getWrap :: m (Wrapped wrapper)) -> m (Wrapped wrapper)
getWrap

findJust :: (a -> Maybe b) -> [a] -> Maybe b
findJust :: (a -> Maybe b) -> [a] -> Maybe b
findJust a -> Maybe b
f [] = Maybe b
forall a. Maybe a
Nothing
findJust a -> Maybe b
f (a
x:[a]
xs) = case a -> Maybe b
f a
x of
   (y :: Maybe b
y@ (Just b
_)) -> Maybe b
y
   Maybe b
Nothing -> (a -> Maybe b) -> [a] -> Maybe b
forall a b. (a -> Maybe b) -> [a] -> Maybe b
findJust a -> Maybe b
f [a]
xs

{- Here is a little example -}
data Tree val =
      Leaf val
   |  Node [Tree val]

instance (Monad m,HasBinary val m) => HasWrapper (Tree val) m where
   wraps :: [Wrap (Tree val) m]
wraps = [
      Byte -> (val -> Tree val) -> Wrap (Tree val) m
forall val (m :: * -> *) wrapper.
HasBinary val m =>
Byte -> (val -> wrapper) -> Wrap wrapper m
wrap1 Byte
0 val -> Tree val
forall val. val -> Tree val
Leaf,
      Byte -> ([Tree val] -> Tree val) -> Wrap (Tree val) m
forall val (m :: * -> *) wrapper.
HasBinary val m =>
Byte -> (val -> wrapper) -> Wrap wrapper m
wrap1 Byte
1 [Tree val] -> Tree val
forall val. [Tree val] -> Tree val
Node
      ]
   unWrap :: Tree val -> UnWrap m
unWrap = (\ Tree val
wrapper -> case Tree val
wrapper of
      Leaf val
v -> Byte -> val -> UnWrap m
forall (m :: * -> *) val.
HasBinary val m =>
Byte -> val -> UnWrap m
UnWrap Byte
0 val
v
      Node [Tree val]
l -> Byte -> [Tree val] -> UnWrap m
forall (m :: * -> *) val.
HasBinary val m =>
Byte -> val -> UnWrap m
UnWrap Byte
1 [Tree val]
l
      )

instance (Monad m,HasWrapper (Tree val) m) => HasBinary (Tree val) m where
   writeBin :: WriteBinary m -> Tree val -> m ()
writeBin = (Tree val -> Wrapped (Tree val))
-> WriteBinary m -> Tree val -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite Tree val -> Wrapped (Tree val)
forall a. a -> Wrapped a
Wrapped
   readBin :: ReadBinary m -> m (Tree val)
readBin = (Wrapped (Tree val) -> Tree val) -> ReadBinary m -> m (Tree val)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead Wrapped (Tree val) -> Tree val
forall a. Wrapped a -> a
wrapped

-- ----------------------------------------------------------------------
-- HasBinary via Strings for things that are instances of Read/Show
-- ----------------------------------------------------------------------

-- | Newtype alias for things we want to encode or decode via their
-- 'Read' or 'Show' 'String' representation.
newtype ReadShow a = ReadShow a

instance (Read a,Show a,Monad m) => HasBinary (ReadShow a) m where
   writeBin :: WriteBinary m -> ReadShow a -> m ()
writeBin = (ReadShow a -> [Char]) -> WriteBinary m -> ReadShow a -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (ReadShow a
a) -> a -> [Char]
forall a. Show a => a -> [Char]
show a
a)
   readBin :: ReadBinary m -> m (ReadShow a)
readBin = ([Char] -> ReadShow a) -> ReadBinary m -> m (ReadShow a)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ [Char]
str ->
      case ReadS a
forall a. Read a => ReadS a
reads [Char]
str of
         [(a
a,[Char]
"")] -> a -> ReadShow a
forall a. a -> ReadShow a
ReadShow a
a
         [(a, [Char])]
_ -> [Char] -> ReadShow a
forall a. HasCallStack => [Char] -> a
error ([Char]
"BinaryUtils.readBin -- couldn't parse " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
str)
      )

-- ----------------------------------------------------------------------
-- HasBinary via numbers for things that are instances of Enum.
-- ----------------------------------------------------------------------


newtype ViaEnum a = ViaEnum {ViaEnum a -> a
enum :: a}

instance (Monad m,Enum a) => HasBinary (ViaEnum a) m where
   writeBin :: WriteBinary m -> ViaEnum a -> m ()
writeBin = (ViaEnum a -> Int) -> WriteBinary m -> ViaEnum a -> m ()
forall b (m :: * -> *) a.
HasBinary b m =>
(a -> b) -> WriteBinary m -> a -> m ()
mapWrite (\ (ViaEnum a
a)
      -> (a -> Int
forall a. Enum a => a -> Int
fromEnum a
a) :: Int
      )
   readBin :: ReadBinary m -> m (ViaEnum a)
readBin = (Int -> ViaEnum a) -> ReadBinary m -> m (ViaEnum a)
forall (m :: * -> *) b a.
(Monad m, HasBinary b m) =>
(b -> a) -> ReadBinary m -> m a
mapRead (\ (Int
aInt :: Int) -> a -> ViaEnum a
forall a. a -> ViaEnum a
ViaEnum (Int -> a
forall a. Enum a => Int -> a
toEnum Int
aInt))