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