-- Experimental - bidirectional codecs
-- See https://hackage.haskell.org/package/codec
-- And https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html
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))