module Generics.Instant.Functions.Bytes
(
gserializeDefault
, gdeserializeDefault
, RepGSerial
, GSerial(..)
, GSumSerial
, GSumSize
) where
import qualified Data.Bytes.Serial as Bytes
import qualified Data.Bytes.Put as Bytes
import qualified Data.Bytes.Get as Bytes
import Data.Bits
import Data.Word
import Generics.Instant
import Prelude
gserializeDefault :: (Representable a, GSerial (Rep a), Bytes.MonadPut m) => a -> m ()
gserializeDefault = \a -> gserialize (from a)
gdeserializeDefault :: (Representable a, GSerial (Rep a), Bytes.MonadGet m) => m a
gdeserializeDefault = fmap to gdeserialize
class (Representable a, GSerial (Rep a)) => RepGSerial a
instance (Representable a, GSerial (Rep a)) => RepGSerial a
class GSerial a where
gserialize :: Bytes.MonadPut m => a -> m ()
gdeserialize :: Bytes.MonadGet m => m a
instance GSerial Z where
gserialize _ = fail "Generics.Instant.Functions.Serial.GSerial Z gserialize - impossible"
gdeserialize = fail "Generics.Instant.Functions.Serial.GSerial Z gdeserialize - impossible"
instance GSerial U where
gserialize U = Bytes.serialize ()
gdeserialize = Bytes.deserialize >>= \() -> return U
instance GSerial a => GSerial (CEq c p p a) where
gserialize (C a) = gserialize a
gdeserialize = gdeserialize >>= \a -> return (C a)
instance GSerial a => GSerial (CEq c p q a) where
gserialize (C a) = gserialize a
gdeserialize = fail "Generics.Instant.Functions.Serial.GSerial (CEq c p q a) gdeserialize - impossible"
instance Bytes.Serial a => GSerial (Var a) where
gserialize (Var a) = Bytes.serialize a
gdeserialize = Bytes.deserialize >>= \a -> return (Var a)
instance Bytes.Serial a => GSerial (Rec a) where
gserialize (Rec a) = Bytes.serialize a
gdeserialize = Bytes.deserialize >>= \a -> return (Rec a)
instance (GSerial a, GSerial b) => GSerial (a :*: b) where
gserialize (a :*: b) = gserialize a >> gserialize b
gdeserialize = gdeserialize >>= \a ->
gdeserialize >>= \b ->
return (a :*: b)
instance
( GSumSerial a, GSumSerial b, GSerial a, GSerial b, GSumSize a, GSumSize b
) => GSerial (a :+: b)
where
gserialize x
| predSize <= fromIntegral (maxBound :: Word8)
= putSum (0 :: Word8) (fromIntegral size) x
| predSize <= fromIntegral (maxBound :: Word16)
= putSum (0 :: Word16) (fromIntegral size) x
| predSize <= fromIntegral (maxBound :: Word32)
= putSum (0 :: Word32) (fromIntegral size) x
| predSize <= fromIntegral (maxBound :: Word64)
= putSum (0 :: Word64) (fromIntegral size) x
| otherwise = sizeError "encode" size
where
size = unTagged (sumSize :: Tagged (a :+: b) Word64)
predSize = size 1
gdeserialize
| predSize <= fromIntegral (maxBound :: Word8)
= Bytes.deserialize >>= \(c :: Word8) ->
checkGetSum (fromIntegral size) c
| predSize <= fromIntegral (maxBound :: Word16)
= Bytes.deserialize >>= \(c :: Word16) ->
checkGetSum (fromIntegral size) c
| predSize <= fromIntegral (maxBound :: Word32)
= Bytes.deserialize >>= \(c :: Word32) ->
checkGetSum (fromIntegral size) c
| predSize <= fromIntegral (maxBound :: Word64)
= Bytes.deserialize >>= \(c :: Word64) ->
checkGetSum (fromIntegral size) c
| otherwise = sizeError "decode" size
where
size = unTagged (sumSize :: Tagged (a :+: b) Word64)
predSize = size 1
sizeError :: Show size => String -> size -> error
sizeError s size =
error $ "Generics.Instant.Functions.Serial.sizeError: Can't " ++ s ++ " a type with " ++
show size ++ " constructors"
checkGetSum
:: (Ord w, Num w, Bits w, GSumSerial a, Bytes.MonadGet m) => w -> w -> m a
checkGetSum size code
| code < size = getSum code size
| otherwise = fail "Generics.Instant.Functions.Serial.checkGetSum: Unknown encoding for constructor"
class GSumSerial a where
putSum :: (Num w, Bits w, Bytes.Serial w, Bytes.MonadPut m) => w -> w -> a -> m ()
getSum :: (Ord w, Num w, Bits w, Bytes.MonadGet m) => w -> w -> m a
instance (GSumSerial a, GSumSerial b, GSerial a, GSerial b) => GSumSerial (a :+: b) where
putSum !code !size x =
let sizeL = size `shiftR` 1
sizeR = size sizeL
in case x of
L l -> putSum code sizeL l
R r -> putSum (code + sizeL) sizeR r
getSum !code !size
| code < sizeL = L <$> getSum code sizeL
| otherwise = R <$> getSum (code sizeL) sizeR
where
sizeL = size `shiftR` 1
sizeR = size sizeL
instance GSerial a => GSumSerial (CEq c p p a) where
putSum !code _ ca = Bytes.serialize code >> gserialize ca
getSum _ _ = gdeserialize
instance GSerial a => GSumSerial (CEq c p q a) where
putSum !code _ ca = Bytes.serialize code >> gserialize ca
getSum _ _ = fail "Generics.Instant.Functions.Serial.GSumSerial (CEq c p q a) getSum - impossible"
class GSumSize a where
sumSize :: Tagged a Word64
newtype Tagged s b = Tagged {unTagged :: b}
instance (GSumSize a, GSumSize b) => GSumSize (a :+: b) where
sumSize = Tagged (unTagged (sumSize :: Tagged a Word64) +
unTagged (sumSize :: Tagged b Word64))
instance GSumSize (CEq c p q a) where
sumSize = Tagged 1