{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}
module Util.BinaryInstances(
Choice5(..),
HasWrapper(..),
Wrapped(..),
UnWrap(..),
wrap0,wrap1,wrap2,wrap3,wrap4,
ReadShow(..),
ViaEnum(..),
Unsigned(..),
) where
import Data.Char
import Control.Monad.Fail
import Data.Bits
import Data.Word
import GHC.Int(Int32)
import Foreign.C.Types
import Util.Bytes
import Util.Binary
import Util.BinaryUtils
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))
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)
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)
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)
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
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)
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))
bitsInByte :: Int
bitsInByte :: Int
bitsInByte = Int
8
bitsPerByte :: Int
bitsPerByte :: Int
bitsPerByte = Int
bitsInByte Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
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)
newtype CodedList = CodedList [Byte]
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))
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)
class HasWrapper wrapper m where
wraps :: [Wrap wrapper m]
unWrap :: wrapper -> UnWrap m
newtype Wrapped a = Wrapped {Wrapped a -> a
wrapped :: a}
data UnWrap m = forall val . HasBinary val m
=> UnWrap
Byte
val
data Wrap wrapper m = forall val . HasBinary val m
=> Wrap
Byte
(val -> wrapper)
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)
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
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)
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)
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
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
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)
)
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))