{-# 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)

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

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

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

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

liftPutList :: (a -> Put) -> [a] -> Put
liftPutList :: forall a. (a -> Put) -> [a] -> Put
liftPutList a -> Put
f [a]
xs = forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) forall a. Semigroup a => a -> a -> a
<> 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 :: forall a. Get a -> Get [a]
liftGetList Get a
g = do
  Int
n <- forall t. Binary t => Get t
get :: Get Int                                                           
  forall a. Get a -> Int -> Get [a]
internalGetMany Get a
g Int
n                                                              

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

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

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