Bytes.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Generics.Instant.Functions.Bytes
  ( -- $defaults
    gserialize
  , gdeserialize
    -- * Internals
  , GSerial
    -- ** Even more internal
  , 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

--------------------------------------------------------------------------------
-- $defaults
--
-- You can use 'gserialize' and 'gdeserialize' as your generic 'Bytes.serialize'
-- and 'Bytes.deserialize' implementations for any 'Representable' type as
-- follows:
--
-- @
-- instance 'Bytes.Serial' MyType where
--    serialize = 'gserialize'
--    deserialize = 'gdeserialize'
-- @

gserialize :: (Representable a, GSerial (Rep a), Bytes.MonadPut m) => a -> m ()
gserialize = \a -> gserialize' (from a)
{-# INLINABLE gserialize #-}

gdeserialize :: (Representable a, GSerial (Rep a), Bytes.MonadGet m) => m a
gdeserialize = fmap to gdeserialize'
{-# INLINABLE gdeserialize #-}

--------------------------------------------------------------------------------

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 ()
  {-# INLINABLE gserialize' #-}
  gdeserialize' = Bytes.deserialize >>= \() -> return U
  {-# INLINABLE gdeserialize' #-}

instance GSerial a => GSerial (CEq c p p a) where
  gserialize' (C a) = gserialize' a
  {-# INLINABLE gserialize' #-}
  gdeserialize' = gdeserialize' >>= \a -> return (C a)
  {-# INLINABLE gdeserialize' #-}

instance {-# OVERLAPPABLE #-} GSerial a => GSerial (CEq c p q a) where
  gserialize' (C a) = gserialize' a
  {-# INLINABLE gserialize' #-}
  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
  {-# INLINABLE gserialize' #-}
  gdeserialize' = Bytes.deserialize >>= \a -> return (Var a)
  {-# INLINABLE gdeserialize' #-}

instance Bytes.Serial a => GSerial (Rec a) where
  gserialize' (Rec a) = Bytes.serialize a
  {-# INLINABLE gserialize' #-}
  gdeserialize' = Bytes.deserialize >>= \a -> return (Rec a)
  {-# INLINABLE gdeserialize' #-}

instance (GSerial a, GSerial b) => GSerial (a :*: b) where
  gserialize' (a :*: b) = gserialize' a >> gserialize' b
  {-# INLINABLE gserialize' #-}
  gdeserialize' = gdeserialize' >>= \a ->
                  gdeserialize' >>= \b ->
                  return (a :*: b)
  {-# INLINABLE gdeserialize' #-}

---

-- Borrowed from the "binary" package, which borrowed this from "cereal".

-- The following GSerial instance for sums has support for serializing
-- types with up to 2^64-1 constructors. It will use the minimal
-- number of bytes needed to encode the constructor. For example when
-- a type has 2^8 constructors or less it will use a single byte to
-- encode the constructor. If it has 2^16 constructors or less it will
-- use two bytes, and so on till 2^64-1.

instance
  ( GSumSerial a, GSumSerial b, GSerial a, GSerial b, GSumSize a, GSumSize b
  ) => GSerial (a :+: b)
  where
    {-# INLINABLE gserialize' #-}
    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

    {-# INLINABLE gdeserialize' #-}
    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"
{-# INLINABLE checkGetSum #-}

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
  {-# INLINABLE putSum #-}
  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
  {-# INLINABLE getSum #-}
  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
  {-# INLINABLE putSum #-}
  getSum _ _ = gdeserialize'
  {-# INLINABLE getSum #-}

instance {-# OVERLAPPABLE #-} GSerial a => GSumSerial (CEq c p q a) where
  putSum !code _ ca = Bytes.serialize code >> gserialize' ca
  {-# INLINABLE putSum #-}
  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
  {-# INLINABLE sumSize #-}
  sumSize = Tagged (unTagged (sumSize :: Tagged a Word64) +
                    unTagged (sumSize :: Tagged b Word64))

instance GSumSize (CEq c p q a) where
  {-# INLINABLE sumSize #-}
  sumSize = Tagged 1