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