module Dahdit.Free
  ( GetStaticSeqF (..)
  , GetStaticArrayF (..)
  , GetLookAheadF (..)
  , GetScopeF (..)
  , ScopeMode (..)
  , GetF (..)
  , Get (..)
  , PutStaticSeqF (..)
  , PutStaticArrayF (..)
  , PutStaticHintF (..)
  , PutF (..)
  , PutM (..)
  , Put
  )
where

import Control.Monad.Free.Church (F (..))
import Dahdit.Nums
  ( DoubleBE
  , DoubleLE
  , FloatBE
  , FloatLE
  , Int16BE
  , Int16LE
  , Int24BE
  , Int24LE
  , Int32BE
  , Int32LE
  , Int64BE
  , Int64LE
  , Word16BE
  , Word16LE
  , Word24BE
  , Word24LE
  , Word32BE
  , Word32LE
  , Word64BE
  , Word64LE
  )
import Dahdit.Sizes (ByteCount, ElemCount, StaticByteSized (..))
import Data.ByteString.Short (ShortByteString)
import Data.Int (Int8)
import Data.Primitive (Prim)
import Data.Primitive.ByteArray (ByteArray)
import Data.Primitive.ByteArray.Unaligned (PrimUnaligned)
import Data.Primitive.PrimArray (PrimArray)
import Data.Proxy (Proxy (..))
import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word8)

data GetStaticSeqF a where
  GetStaticSeqF :: (StaticByteSized z) => !ElemCount -> Get z -> (Seq z -> a) -> GetStaticSeqF a

instance Functor GetStaticSeqF where
  fmap :: forall a b. (a -> b) -> GetStaticSeqF a -> GetStaticSeqF b
fmap a -> b
f (GetStaticSeqF ElemCount
n Get z
g Seq z -> a
k) = ElemCount -> Get z -> (Seq z -> b) -> GetStaticSeqF b
forall z a.
StaticByteSized z =>
ElemCount -> Get z -> (Seq z -> a) -> GetStaticSeqF a
GetStaticSeqF ElemCount
n Get z
g (a -> b
f (a -> b) -> (Seq z -> a) -> Seq z -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq z -> a
k)

data GetStaticArrayF a where
  GetStaticArrayF :: (Prim z, PrimUnaligned z) => !ElemCount -> Proxy z -> (PrimArray z -> a) -> GetStaticArrayF a

instance Functor GetStaticArrayF where
  fmap :: forall a b. (a -> b) -> GetStaticArrayF a -> GetStaticArrayF b
fmap a -> b
f (GetStaticArrayF ElemCount
n Proxy z
p PrimArray z -> a
k) = ElemCount -> Proxy z -> (PrimArray z -> b) -> GetStaticArrayF b
forall z a.
(Prim z, PrimUnaligned z) =>
ElemCount -> Proxy z -> (PrimArray z -> a) -> GetStaticArrayF a
GetStaticArrayF ElemCount
n Proxy z
p (a -> b
f (a -> b) -> (PrimArray z -> a) -> PrimArray z -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimArray z -> a
k)

data GetLookAheadF a where
  GetLookAheadF :: Get z -> (z -> a) -> GetLookAheadF a

instance Functor GetLookAheadF where
  fmap :: forall a b. (a -> b) -> GetLookAheadF a -> GetLookAheadF b
fmap a -> b
f (GetLookAheadF Get z
g z -> a
k) = Get z -> (z -> b) -> GetLookAheadF b
forall z a. Get z -> (z -> a) -> GetLookAheadF a
GetLookAheadF Get z
g (a -> b
f (a -> b) -> (z -> a) -> z -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. z -> a
k)

data GetScopeF a where
  GetScopeF :: !ScopeMode -> !ByteCount -> Get z -> (z -> a) -> GetScopeF a

instance Functor GetScopeF where
  fmap :: forall a b. (a -> b) -> GetScopeF a -> GetScopeF b
fmap a -> b
f (GetScopeF ScopeMode
sm ByteCount
bc Get z
g z -> a
k) = ScopeMode -> ByteCount -> Get z -> (z -> b) -> GetScopeF b
forall z a.
ScopeMode -> ByteCount -> Get z -> (z -> a) -> GetScopeF a
GetScopeF ScopeMode
sm ByteCount
bc Get z
g (a -> b
f (a -> b) -> (z -> a) -> z -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. z -> a
k)

data ScopeMode
  = ScopeModeExact
  | ScopeModeWithin
  deriving stock (ScopeMode -> ScopeMode -> Bool
(ScopeMode -> ScopeMode -> Bool)
-> (ScopeMode -> ScopeMode -> Bool) -> Eq ScopeMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScopeMode -> ScopeMode -> Bool
== :: ScopeMode -> ScopeMode -> Bool
$c/= :: ScopeMode -> ScopeMode -> Bool
/= :: ScopeMode -> ScopeMode -> Bool
Eq, Int -> ScopeMode -> ShowS
[ScopeMode] -> ShowS
ScopeMode -> String
(Int -> ScopeMode -> ShowS)
-> (ScopeMode -> String)
-> ([ScopeMode] -> ShowS)
-> Show ScopeMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScopeMode -> ShowS
showsPrec :: Int -> ScopeMode -> ShowS
$cshow :: ScopeMode -> String
show :: ScopeMode -> String
$cshowList :: [ScopeMode] -> ShowS
showList :: [ScopeMode] -> ShowS
Show)

data GetF a
  = GetFWord8 (Word8 -> a)
  | GetFInt8 (Int8 -> a)
  | GetFWord16LE (Word16LE -> a)
  | GetFInt16LE (Int16LE -> a)
  | GetFWord24LE (Word24LE -> a)
  | GetFInt24LE (Int24LE -> a)
  | GetFWord32LE (Word32LE -> a)
  | GetFInt32LE (Int32LE -> a)
  | GetFWord64LE (Word64LE -> a)
  | GetFInt64LE (Int64LE -> a)
  | GetFFloatLE (FloatLE -> a)
  | GetFDoubleLE (DoubleLE -> a)
  | GetFWord16BE (Word16BE -> a)
  | GetFInt16BE (Int16BE -> a)
  | GetFWord24BE (Word24BE -> a)
  | GetFInt24BE (Int24BE -> a)
  | GetFWord32BE (Word32BE -> a)
  | GetFInt32BE (Int32BE -> a)
  | GetFWord64BE (Word64BE -> a)
  | GetFInt64BE (Int64BE -> a)
  | GetFFloatBE (FloatBE -> a)
  | GetFDoubleBE (DoubleBE -> a)
  | GetFShortByteString !ByteCount (ShortByteString -> a)
  | GetFStaticSeq !(GetStaticSeqF a)
  | GetFStaticArray !(GetStaticArrayF a)
  | GetFByteArray !ByteCount (ByteArray -> a)
  | GetFScope !(GetScopeF a)
  | GetFSkip !ByteCount a
  | GetFLookAhead !(GetLookAheadF a)
  | GetFRemainingSize (ByteCount -> a)
  | GetFFail !Text
  deriving stock ((forall a b. (a -> b) -> GetF a -> GetF b)
-> (forall a b. a -> GetF b -> GetF a) -> Functor GetF
forall a b. a -> GetF b -> GetF a
forall a b. (a -> b) -> GetF a -> GetF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> GetF a -> GetF b
fmap :: forall a b. (a -> b) -> GetF a -> GetF b
$c<$ :: forall a b. a -> GetF b -> GetF a
<$ :: forall a b. a -> GetF b -> GetF a
Functor)

newtype Get a = Get {forall a. Get a -> F GetF a
unGet :: F GetF a}
  deriving newtype ((forall a b. (a -> b) -> Get a -> Get b)
-> (forall a b. a -> Get b -> Get a) -> Functor Get
forall a b. a -> Get b -> Get a
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Get a -> Get b
fmap :: forall a b. (a -> b) -> Get a -> Get b
$c<$ :: forall a b. a -> Get b -> Get a
<$ :: forall a b. a -> Get b -> Get a
Functor, Functor Get
Functor Get =>
(forall a. a -> Get a)
-> (forall a b. Get (a -> b) -> Get a -> Get b)
-> (forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c)
-> (forall a b. Get a -> Get b -> Get b)
-> (forall a b. Get a -> Get b -> Get a)
-> Applicative Get
forall a. a -> Get a
forall a b. Get a -> Get b -> Get a
forall a b. Get a -> Get b -> Get b
forall a b. Get (a -> b) -> Get a -> Get b
forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Get a
pure :: forall a. a -> Get a
$c<*> :: forall a b. Get (a -> b) -> Get a -> Get b
<*> :: forall a b. Get (a -> b) -> Get a -> Get b
$cliftA2 :: forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c
liftA2 :: forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c
$c*> :: forall a b. Get a -> Get b -> Get b
*> :: forall a b. Get a -> Get b -> Get b
$c<* :: forall a b. Get a -> Get b -> Get a
<* :: forall a b. Get a -> Get b -> Get a
Applicative, Applicative Get
Applicative Get =>
(forall a b. Get a -> (a -> Get b) -> Get b)
-> (forall a b. Get a -> Get b -> Get b)
-> (forall a. a -> Get a)
-> Monad Get
forall a. a -> Get a
forall a b. Get a -> Get b -> Get b
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Get a -> (a -> Get b) -> Get b
>>= :: forall a b. Get a -> (a -> Get b) -> Get b
$c>> :: forall a b. Get a -> Get b -> Get b
>> :: forall a b. Get a -> Get b -> Get b
$creturn :: forall a. a -> Get a
return :: forall a. a -> Get a
Monad)

instance MonadFail Get where
  fail :: forall a. String -> Get a
fail String
msg = F GetF a -> Get a
forall a. F GetF a -> Get a
Get ((forall r. (a -> r) -> (GetF r -> r) -> r) -> F GetF a
forall (f :: * -> *) a.
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
F (\a -> r
_ GetF r -> r
y -> GetF r -> r
y (Text -> GetF r
forall a. Text -> GetF a
GetFFail (String -> Text
T.pack String
msg))))

data PutStaticSeqF a where
  PutStaticSeqF :: (StaticByteSized z) => !ElemCount -> !(Maybe z) -> (z -> Put) -> !(Seq z) -> a -> PutStaticSeqF a

instance Functor PutStaticSeqF where
  fmap :: forall a b. (a -> b) -> PutStaticSeqF a -> PutStaticSeqF b
fmap a -> b
f (PutStaticSeqF ElemCount
n Maybe z
z z -> Put
p Seq z
s a
k) = ElemCount -> Maybe z -> (z -> Put) -> Seq z -> b -> PutStaticSeqF b
forall z a.
StaticByteSized z =>
ElemCount -> Maybe z -> (z -> Put) -> Seq z -> a -> PutStaticSeqF a
PutStaticSeqF ElemCount
n Maybe z
z z -> Put
p Seq z
s (a -> b
f a
k)

data PutStaticArrayF a where
  PutStaticArrayF :: (Prim z, PrimUnaligned z) => !ElemCount -> !(Maybe z) -> !(PrimArray z) -> a -> PutStaticArrayF a

instance Functor PutStaticArrayF where
  fmap :: forall a b. (a -> b) -> PutStaticArrayF a -> PutStaticArrayF b
fmap a -> b
f (PutStaticArrayF ElemCount
n Maybe z
z PrimArray z
a a
k) = ElemCount -> Maybe z -> PrimArray z -> b -> PutStaticArrayF b
forall z a.
(Prim z, PrimUnaligned z) =>
ElemCount -> Maybe z -> PrimArray z -> a -> PutStaticArrayF a
PutStaticArrayF ElemCount
n Maybe z
z PrimArray z
a (a -> b
f a
k)

data PutStaticHintF a where
  PutStaticHintF :: !ByteCount -> Put -> a -> PutStaticHintF a

instance Functor PutStaticHintF where
  fmap :: forall a b. (a -> b) -> PutStaticHintF a -> PutStaticHintF b
fmap a -> b
f (PutStaticHintF ByteCount
n Put
p a
k) = ByteCount -> Put -> b -> PutStaticHintF b
forall a. ByteCount -> Put -> a -> PutStaticHintF a
PutStaticHintF ByteCount
n Put
p (a -> b
f a
k)

data PutF a
  = PutFWord8 !Word8 a
  | PutFInt8 !Int8 a
  | PutFWord16LE !Word16LE a
  | PutFInt16LE !Int16LE a
  | PutFWord24LE !Word24LE a
  | PutFInt24LE !Int24LE a
  | PutFWord32LE !Word32LE a
  | PutFInt32LE !Int32LE a
  | PutFWord64LE !Word64LE a
  | PutFInt64LE !Int64LE a
  | PutFFloatLE !FloatLE a
  | PutFDoubleLE !DoubleLE a
  | PutFWord16BE !Word16BE a
  | PutFInt16BE !Int16BE a
  | PutFWord24BE !Word24BE a
  | PutFInt24BE !Int24BE a
  | PutFWord32BE !Word32BE a
  | PutFWord64BE !Word64BE a
  | PutFInt64BE !Int64BE a
  | PutFInt32BE !Int32BE a
  | PutFFloatBE !FloatBE a
  | PutFDoubleBE !DoubleBE a
  | PutFShortByteString !ByteCount !ShortByteString a
  | PutFStaticSeq !(PutStaticSeqF a)
  | PutFStaticArray !(PutStaticArrayF a)
  | PutFByteArray !ByteCount !ByteArray a
  | PutFStaticHint !(PutStaticHintF a)
  deriving stock ((forall a b. (a -> b) -> PutF a -> PutF b)
-> (forall a b. a -> PutF b -> PutF a) -> Functor PutF
forall a b. a -> PutF b -> PutF a
forall a b. (a -> b) -> PutF a -> PutF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PutF a -> PutF b
fmap :: forall a b. (a -> b) -> PutF a -> PutF b
$c<$ :: forall a b. a -> PutF b -> PutF a
<$ :: forall a b. a -> PutF b -> PutF a
Functor)

newtype PutM a = PutM {forall a. PutM a -> F PutF a
unPutM :: F PutF a}
  deriving newtype ((forall a b. (a -> b) -> PutM a -> PutM b)
-> (forall a b. a -> PutM b -> PutM a) -> Functor PutM
forall a b. a -> PutM b -> PutM a
forall a b. (a -> b) -> PutM a -> PutM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PutM a -> PutM b
fmap :: forall a b. (a -> b) -> PutM a -> PutM b
$c<$ :: forall a b. a -> PutM b -> PutM a
<$ :: forall a b. a -> PutM b -> PutM a
Functor, Functor PutM
Functor PutM =>
(forall a. a -> PutM a)
-> (forall a b. PutM (a -> b) -> PutM a -> PutM b)
-> (forall a b c. (a -> b -> c) -> PutM a -> PutM b -> PutM c)
-> (forall a b. PutM a -> PutM b -> PutM b)
-> (forall a b. PutM a -> PutM b -> PutM a)
-> Applicative PutM
forall a. a -> PutM a
forall a b. PutM a -> PutM b -> PutM a
forall a b. PutM a -> PutM b -> PutM b
forall a b. PutM (a -> b) -> PutM a -> PutM b
forall a b c. (a -> b -> c) -> PutM a -> PutM b -> PutM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> PutM a
pure :: forall a. a -> PutM a
$c<*> :: forall a b. PutM (a -> b) -> PutM a -> PutM b
<*> :: forall a b. PutM (a -> b) -> PutM a -> PutM b
$cliftA2 :: forall a b c. (a -> b -> c) -> PutM a -> PutM b -> PutM c
liftA2 :: forall a b c. (a -> b -> c) -> PutM a -> PutM b -> PutM c
$c*> :: forall a b. PutM a -> PutM b -> PutM b
*> :: forall a b. PutM a -> PutM b -> PutM b
$c<* :: forall a b. PutM a -> PutM b -> PutM a
<* :: forall a b. PutM a -> PutM b -> PutM a
Applicative, Applicative PutM
Applicative PutM =>
(forall a b. PutM a -> (a -> PutM b) -> PutM b)
-> (forall a b. PutM a -> PutM b -> PutM b)
-> (forall a. a -> PutM a)
-> Monad PutM
forall a. a -> PutM a
forall a b. PutM a -> PutM b -> PutM b
forall a b. PutM a -> (a -> PutM b) -> PutM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. PutM a -> (a -> PutM b) -> PutM b
>>= :: forall a b. PutM a -> (a -> PutM b) -> PutM b
$c>> :: forall a b. PutM a -> PutM b -> PutM b
>> :: forall a b. PutM a -> PutM b -> PutM b
$creturn :: forall a. a -> PutM a
return :: forall a. a -> PutM a
Monad)

instance Semigroup (PutM ()) where
  Put
p <> :: Put -> Put -> Put
<> Put
q = Put
p Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Put
q

instance Monoid (PutM ()) where
  mappend :: Put -> Put -> Put
mappend = Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: Put
mempty = () -> Put
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

type Put = PutM ()