{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Binary.Lifted
  ( Binary1(..)
  , put1
  , get1
  ) where

import Data.Binary (Get,Put,Binary,get,put)
import Data.Functor.Compose (Compose(..))
import Data.Word (Word8)
import Data.Semigroup ((<>))

class Binary1 f where
  liftPut :: (a -> Put) -> f a -> Put
  liftGet :: Get a -> Get (f a)

instance Binary1 [] where
  liftPut :: (a -> Put) -> [a] -> Put
liftPut = (a -> Put) -> [a] -> Put
forall a. (a -> Put) -> [a] -> Put
liftPutList
  liftGet :: Get a -> Get [a]
liftGet = Get a -> Get [a]
forall a. Get a -> Get [a]
liftGetList

instance Binary1 Maybe where
  liftPut :: (a -> Put) -> Maybe a -> Put
liftPut a -> Put
_ Maybe a
Nothing  = Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0 :: Word8)
  liftPut a -> Put
f (Just a
x) = Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
1 :: Word8) Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> a -> Put
f a
x
  liftGet :: Get a -> Get (Maybe a)
liftGet Get a
f = do
    (Word8
w :: Word8) <- Get Word8
forall t. Binary t => Get t
get
    case Word8
w of
      Word8
0 -> Maybe a -> Get (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      Word8
_ -> (a -> Maybe a) -> Get a -> Get (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just Get a
f

instance (Binary1 f, Binary1 g) => Binary1 (Compose f g) where
  liftPut :: (a -> Put) -> Compose f g a -> Put
liftPut a -> Put
f (Compose f (g a)
x) = (g a -> Put) -> f (g a) -> Put
forall (f :: * -> *) a. Binary1 f => (a -> Put) -> f a -> Put
liftPut ((a -> Put) -> g a -> Put
forall (f :: * -> *) a. Binary1 f => (a -> Put) -> f a -> Put
liftPut a -> Put
f) f (g a)
x
  liftGet :: Get a -> Get (Compose f g a)
liftGet Get a
f = (f (g a) -> Compose f g a) -> Get (f (g a)) -> Get (Compose f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (g a) -> Compose f g a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Get (g a) -> Get (f (g a))
forall (f :: * -> *) a. Binary1 f => Get a -> Get (f a)
liftGet (Get a -> Get (g a)
forall (f :: * -> *) a. Binary1 f => Get a -> Get (f a)
liftGet Get a
f))

liftPutList :: (a -> Put) -> [a] -> Put
liftPutList :: (a -> Put) -> [a] -> Put
liftPutList a -> Put
f [a]
xs = Int -> Put
forall t. Binary t => t -> Put
put ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
f [a]
xs                                

liftGetList :: Get a -> Get [a]                                                    
liftGetList :: Get a -> Get [a]
liftGetList Get a
g = do
  Int
n <- Get Int
forall t. Binary t => Get t
get :: Get Int                                                           
  Get a -> Int -> Get [a]
forall a. Get a -> Int -> Get [a]
internalGetMany Get a
g Int
n                                                              

internalGetMany :: Get a -> Int -> Get [a]                                         
internalGetMany :: Get a -> Int -> Get [a]
internalGetMany Get a
g Int
n = [a] -> Int -> Get [a]
forall t. (Eq t, Num t) => [a] -> t -> Get [a]
go [] Int
n                                                      
  where 
  go :: [a] -> t -> Get [a]
go [a]
xs !t
0 = [a] -> Get [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Get [a]) -> [a] -> Get [a]
forall a b. (a -> b) -> a -> b
$! [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs                                                  
  go [a]
xs !t
i = do                                                                    
    !a
x <- Get a
g
    [a] -> t -> Get [a]
go (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) (t
it -> t -> t
forall a. Num a => a -> a -> a
-t
1)                                                                

get1 :: (Binary1 f, Binary a) => Get (f a)
get1 :: Get (f a)
get1 = Get a -> Get (f a)
forall (f :: * -> *) a. Binary1 f => Get a -> Get (f a)
liftGet Get a
forall t. Binary t => Get t
get

put1 :: (Binary1 f, Binary a) => f a -> Put
put1 :: f a -> Put
put1 = (a -> Put) -> f a -> Put
forall (f :: * -> *) a. Binary1 f => (a -> Put) -> f a -> Put
liftPut a -> Put
forall t. Binary t => t -> Put
put