module Dahdit.Codec
( Codec
, build
, binary
, parse
, produce
, bindPair
, bindTag
, HasCodec (..)
, ViaBinary (..)
, ViaCodec (..)
)
where
import Dahdit.Binary (Binary (..))
import Dahdit.Fancy (BoolByte, ExactBytes, StaticArray, StaticSeq, TermBytes)
import Dahdit.Free (Get, Put)
import Dahdit.LiftedPrim (LiftedPrim)
import Dahdit.Nums (FloatBE, FloatLE, Int16BE, Int16LE, Int24BE, Int24LE, Int32BE, Int32LE, Word16BE, Word16LE, Word24BE, Word24LE, Word32BE, Word32LE)
import Dahdit.Sizes (ByteSized (..), StaticByteSized)
import Data.Coerce (coerce)
import Data.Default (Default)
import Data.Int (Int8)
import Data.Word (Word8)
import GHC.TypeLits (KnownNat, KnownSymbol)
data Codec' x a = Codec'
{ forall x a. Codec' x a -> Get a
parse' :: Get a
, forall x a. Codec' x a -> x -> Put
produce' :: x -> Put
}
instance Functor (Codec' x) where
fmap :: forall a b. (a -> b) -> Codec' x a -> Codec' x b
fmap a -> b
f Codec' x a
c = Codec' x a
c {parse' :: Get b
parse' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (forall x a. Codec' x a -> Get a
parse' Codec' x a
c)}
instance Applicative (Codec' x) where
pure :: forall a. a -> Codec' x a
pure a
a = forall x a. Get a -> (x -> Put) -> Codec' x a
Codec' (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
Codec' x (a -> b)
f <*> :: forall a b. Codec' x (a -> b) -> Codec' x a -> Codec' x b
<*> Codec' x a
a =
Codec'
{ parse' :: Get b
parse' = forall x a. Codec' x a -> Get a
parse' Codec' x (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x a. Codec' x a -> Get a
parse' Codec' x a
a
, produce' :: x -> Put
produce' = \x
x -> forall x a. Codec' x a -> x -> Put
produce' Codec' x (a -> b)
f x
x forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall x a. Codec' x a -> x -> Put
produce' Codec' x a
a x
x
}
type Codec a = Codec' a a
build :: Get a -> (a -> Put) -> Codec a
build :: forall a. Get a -> (a -> Put) -> Codec a
build = forall x a. Get a -> (x -> Put) -> Codec' x a
Codec'
binary :: Binary a => Codec a
binary :: forall a. Binary a => Codec a
binary = forall a. Get a -> (a -> Put) -> Codec a
build forall a. Binary a => Get a
get forall a. Binary a => a -> Put
put
parse :: Codec a -> Get a
parse :: forall a. Codec a -> Get a
parse = forall x a. Codec' x a -> Get a
parse'
produce :: Codec a -> a -> Put
produce :: forall a. Codec a -> a -> Put
produce = forall x a. Codec' x a -> x -> Put
produce'
bindPair :: Codec a -> (a -> Codec b) -> Codec (a, b)
bindPair :: forall a b. Codec a -> (a -> Codec b) -> Codec (a, b)
bindPair Codec a
c a -> Codec b
f =
forall x a. Get a -> (x -> Put) -> Codec' x a
Codec'
(forall a. Codec a -> Get a
parse Codec a
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
a,) (forall a. Codec a -> Get a
parse (a -> Codec b
f a
a)))
(\(a
a, b
b) -> forall a. Codec a -> a -> Put
produce Codec a
c a
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Codec a -> a -> Put
produce (a -> Codec b
f a
a) b
b)
bindTag :: (b -> a) -> Codec a -> (a -> Codec b) -> Codec b
bindTag :: forall b a. (b -> a) -> Codec a -> (a -> Codec b) -> Codec b
bindTag b -> a
t Codec a
c a -> Codec b
f =
forall x a. Get a -> (x -> Put) -> Codec' x a
Codec'
(forall a. Codec a -> Get a
parse Codec a
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Codec a -> Get a
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Codec b
f)
(\b
b -> let a :: a
a = b -> a
t b
b in forall a. Codec a -> a -> Put
produce Codec a
c a
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Codec a -> a -> Put
produce (a -> Codec b
f a
a) b
b)
class HasCodec a where
codec :: Codec a
newtype ViaBinary a = ViaBinary {forall a. ViaBinary a -> a
unViaBinary :: a}
instance Binary a => HasCodec (ViaBinary a) where
codec :: Codec (ViaBinary a)
codec = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Binary a => Codec a
binary @a)
deriving via (ViaBinary Word8) instance HasCodec Word8
deriving via (ViaBinary Int8) instance HasCodec Int8
deriving via (ViaBinary Word16LE) instance HasCodec Word16LE
deriving via (ViaBinary Int16LE) instance HasCodec Int16LE
deriving via (ViaBinary Word24LE) instance HasCodec Word24LE
deriving via (ViaBinary Int24LE) instance HasCodec Int24LE
deriving via (ViaBinary Word32LE) instance HasCodec Word32LE
deriving via (ViaBinary Int32LE) instance HasCodec Int32LE
deriving via (ViaBinary FloatLE) instance HasCodec FloatLE
deriving via (ViaBinary Word16BE) instance HasCodec Word16BE
deriving via (ViaBinary Int16BE) instance HasCodec Int16BE
deriving via (ViaBinary Word24BE) instance HasCodec Word24BE
deriving via (ViaBinary Int24BE) instance HasCodec Int24BE
deriving via (ViaBinary Word32BE) instance HasCodec Word32BE
deriving via (ViaBinary Int32BE) instance HasCodec Int32BE
deriving via (ViaBinary FloatBE) instance HasCodec FloatBE
deriving via (ViaBinary TermBytes) instance HasCodec TermBytes
deriving via (ViaBinary (StaticSeq n a)) instance (KnownNat n, Binary a, StaticByteSized a, Default a) => HasCodec (StaticSeq n a)
deriving via (ViaBinary (StaticArray n a)) instance (KnownNat n, LiftedPrim a, Default a) => HasCodec (StaticArray n a)
deriving via (ViaBinary BoolByte) instance HasCodec BoolByte
deriving via (ViaBinary (ExactBytes s)) instance KnownSymbol s => HasCodec (ExactBytes s)
newtype ViaCodec a = ViaCodec {forall a. ViaCodec a -> a
unViaCodec :: a}
instance ByteSized a => ByteSized (ViaCodec a) where
byteSize :: ViaCodec a -> ByteCount
byteSize = forall a. ByteSized a => a -> ByteCount
byteSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ViaCodec a -> a
unViaCodec
instance HasCodec a => Binary (ViaCodec a) where
get :: Get (ViaCodec a)
get = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Codec a -> Get a
parse (forall a. HasCodec a => Codec a
codec @a))
put :: ViaCodec a -> Put
put = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Codec a -> a -> Put
produce (forall a. HasCodec a => Codec a
codec @a))