{-# LANGUAGE UndecidableInstances #-} -- for Generically instance

module Binrep.Get.Struct where

import Binrep.Get.Error
import Bytezap.Parser.Struct
import Bytezap.Parser.Struct.Generic
import Binrep.CBLen
import Foreign.Ptr ( Ptr )
import Data.Void ( Void )
import GHC.Exts ( Proxy#, Int(I#) )
import GHC.TypeNats ( KnownNat )
import GHC.Generics

import Binrep.Common.Via.Prim ( ViaPrim(..) )
import Raehik.Compat.Data.Primitive.Types ( Prim' )

import Data.Word ( Word8 )
import Data.Int ( Int8 )
import Binrep.Util.ByteOrder
import Data.Functor.Identity
import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap )

import Data.ByteString qualified as B

import Generic.Type.Assert

import Binrep.Common.Via.Generically.NonSum

import Refined
import Refined.Unsafe

type GetterC = Parser E

-- | constant size parser
class GetC a where getC :: GetterC a

runGetCBs
    :: forall a. (GetC a, KnownNat (CBLen a))
    => B.ByteString -> Either E a
runGetCBs :: forall a. (GetC a, KnownNat (CBLen a)) => ByteString -> Either E a
runGetCBs ByteString
bs =
    if   forall a. KnownNat (CBLen a) => Int
forall {k} (a :: k). KnownNat (CBLen a) => Int
cblen @a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= ByteString -> Int
B.length ByteString
bs
    then (forall e. ByteString -> Parser e a -> Result e a)
-> ByteString -> Either E a
forall a buf.
GetC a =>
(forall e. buf -> Parser e a -> Result e a) -> buf -> Either E a
unsafeRunGetC' ByteString -> Parser e a -> Result e a
forall e. ByteString -> Parser e a -> Result e a
forall a e. ByteString -> Parser e a -> Result e a
unsafeRunParserBs ByteString
bs
    else E -> Either E a
forall a b. a -> Either a b
Left (E -> Either E a) -> E -> Either E a
forall a b. (a -> b) -> a -> b
$ Int -> EMiddle -> E
E Int
0 (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ EBase -> EMiddle
EBase (EBase -> EMiddle) -> EBase -> EMiddle
forall a b. (a -> b) -> a -> b
$ Int -> EBase
ERanOut Int
0 -- TODO made up numbers

-- | doesn't check len
unsafeRunGetC'
    :: forall a buf. GetC a
    => (forall e. buf -> Parser e a -> Result e a)
    -> buf -> Either E a
unsafeRunGetC' :: forall a buf.
GetC a =>
(forall e. buf -> Parser e a -> Result e a) -> buf -> Either E a
unsafeRunGetC' forall e. buf -> Parser e a -> Result e a
p buf
buf =
    case buf -> Parser E a -> Result E a
forall e. buf -> Parser e a -> Result e a
p buf
buf Parser E a
forall a. GetC a => GetterC a
getC of
      OK   a
a -> a -> Either E a
forall a b. b -> Either a b
Right a
a
      Result E a
Fail   -> E -> Either E a
forall a b. a -> Either a b
Left E
EFail
      Err  E
e -> E -> Either E a
forall a b. a -> Either a b
Left E
e

-- | doesn't check len
unsafeRunGetCPtr
    :: forall a. GetC a
    => Ptr Word8 -> Either E a
unsafeRunGetCPtr :: forall a. GetC a => Ptr Word8 -> Either E a
unsafeRunGetCPtr = (forall e. Ptr Word8 -> Parser e a -> Result e a)
-> Ptr Word8 -> Either E a
forall a buf.
GetC a =>
(forall e. buf -> Parser e a -> Result e a) -> buf -> Either E a
unsafeRunGetC' Ptr Word8 -> Parser e a -> Result e a
forall e. Ptr Word8 -> Parser e a -> Result e a
forall a e. Ptr Word8 -> Parser e a -> Result e a
unsafeRunParserPtr

instance GParseBase GetC where
    type GParseBaseSt GetC = Proxy# Void
    type GParseBaseC  GetC a = GetC a
    type GParseBaseE  GetC = E
    gParseBase :: forall a.
GParseBaseC GetC a =>
ParserT (GParseBaseSt GetC) (GParseBaseE GetC) a
gParseBase = GetterC a
ParserT (GParseBaseSt GetC) (GParseBaseE GetC) a
forall a. GetC a => GetterC a
getC
    type GParseBaseLenTF GetC = CBLenSym

-- | Serialize a term of the struct-like type @a@ via its 'Generic' instance.
getGenericStruct
    :: forall a
    .  ( Generic a, GParse GetC (Rep a)
       , GAssertNotVoid a, GAssertNotSum a
    ) => GetterC a
getGenericStruct :: forall a.
(Generic a, GParse GetC (Rep a), GAssertNotVoid a,
 GAssertNotSum a) =>
GetterC a
getGenericStruct = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a)
-> ParserT PureMode E (Rep a Any) -> ParserT PureMode E a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k1} (tag :: k) (gf :: k1 -> Type) (p :: k1).
GParse tag gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
forall (tag :: Type -> Constraint) (gf :: Type -> Type) p.
GParse tag gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
gParse @GetC

instance
  ( Generic a, GParse GetC (Rep a)
  , GAssertNotVoid a, GAssertNotSum a
  ) => GetC (Generically a) where
    getC :: GetterC (Generically a)
getC = a -> Generically a
forall a. a -> Generically a
Generically (a -> Generically a)
-> ParserT PureMode E a -> GetterC (Generically a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E a
forall a.
(Generic a, GParse GetC (Rep a), GAssertNotVoid a,
 GAssertNotSum a) =>
GetterC a
getGenericStruct

instance
  ( Generic a, GParse GetC (Rep a)
  , GAssertNotVoid a, GAssertNotSum a
  ) => GetC (GenericallyNonSum a) where
    getC :: GetterC (GenericallyNonSum a)
getC = a -> GenericallyNonSum a
forall a. a -> GenericallyNonSum a
GenericallyNonSum (a -> GenericallyNonSum a)
-> ParserT PureMode E a -> GetterC (GenericallyNonSum a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E a
forall a.
(Generic a, GParse GetC (Rep a), GAssertNotVoid a,
 GAssertNotSum a) =>
GetterC a
getGenericStruct

instance GetC (Refined pr (Refined pl a))
  => GetC (Refined (pl `And` pr) a) where
    getC :: GetterC (Refined (And pl pr) a)
getC = (a -> Refined (And pl pr) a
forall {k} x (p :: k). x -> Refined p x
reallyUnsafeRefine (a -> Refined (And pl pr) a)
-> (Refined pr (Refined pl a) -> a)
-> Refined pr (Refined pl a)
-> Refined (And pl pr) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: k) x. Refined p x -> x
forall {k} (p :: k) x. Refined p x -> x
unrefine @pl (Refined pl a -> a)
-> (Refined pr (Refined pl a) -> Refined pl a)
-> Refined pr (Refined pl a)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: k1) x. Refined p x -> x
forall {k} (p :: k) x. Refined p x -> x
unrefine @pr) (Refined pr (Refined pl a) -> Refined (And pl pr) a)
-> ParserT PureMode E (Refined pr (Refined pl a))
-> GetterC (Refined (And pl pr) a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E (Refined pr (Refined pl a))
forall a. GetC a => GetterC a
getC

instance GetC () where
    {-# INLINE getC #-}
    getC :: GetterC ()
getC = () -> GetterC ()
forall a (st :: ZeroBitType) e. a -> ParserT st e a
constParse ()

instance Prim' a => GetC (ViaPrim a) where
    getC :: GetterC (ViaPrim a)
getC = a -> ViaPrim a
forall a. a -> ViaPrim a
ViaPrim (a -> ViaPrim a) -> ParserT PureMode E a -> GetterC (ViaPrim a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E a
forall a (st :: ZeroBitType) e. Prim' a => ParserT st e a
prim
    {-# INLINE getC #-}

instance GetC a => GetC (Identity a) where getC :: GetterC (Identity a)
getC = a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> ParserT PureMode E a -> GetterC (Identity a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E a
forall a. GetC a => GetterC a
getC

deriving via ViaPrim Word8 instance GetC Word8
deriving via ViaPrim  Int8 instance GetC  Int8
deriving via Word8 instance GetC (ByteOrdered end Word8)
deriving via  Int8 instance GetC (ByteOrdered end  Int8)

-- ByteSwap is required on opposite endian platforms, but we're not checking
-- here, so make sure to keep it on both.
deriving via ViaPrim (ByteOrdered 'LittleEndian a)
    instance (Prim' a, ByteSwap a) => GetC (ByteOrdered 'LittleEndian a)
deriving via ViaPrim (ByteOrdered    'BigEndian a)
    instance (Prim' a, ByteSwap a) => GetC (ByteOrdered    'BigEndian a)

{-

instance TypeError ENoEmpty => PutC Void where putC = undefined
instance TypeError ENoSum => PutC (Either a b) where putC = undefined

instance PutC a => PutC (Identity a) where putC = putC . runIdentity

instance PutC PutterC where putC = id

-- | Look weird? Yeah. But it's correct :)
instance (PutC l, KnownNat (CBLen l), PutC r) => PutC (l, r) where
    {-# INLINE putC #-}
    putC (l, r) = sequencePokes (putC l) (cblen @l) (putC r)

-}

eCBase :: EBase -> GetterC a
eCBase :: forall a. EBase -> GetterC a
eCBase EBase
eb = ParserT# PureMode E a -> ParserT PureMode E a
forall (st :: ZeroBitType) e a. ParserT# st e a -> ParserT st e a
ParserT (ParserT# PureMode E a -> ParserT PureMode E a)
-> ParserT# PureMode E a -> ParserT PureMode E a
forall a b. (a -> b) -> a -> b
$ \ForeignPtrContents
_fpc Addr#
_base Int#
os# PureMode
st ->
    PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
Err# PureMode
st (Int -> EMiddle -> E
E (Int# -> Int
I# Int#
os#) (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ EBase -> EMiddle
EBase EBase
eb)

getECBase :: GetterC a -> EBase -> GetterC a
getECBase :: forall a. GetterC a -> EBase -> GetterC a
getECBase (ParserT ParserT# PureMode E a
p) EBase
eb = ParserT# PureMode E a -> ParserT PureMode E a
forall (st :: ZeroBitType) e a. ParserT# st e a -> ParserT st e a
ParserT (ParserT# PureMode E a -> ParserT PureMode E a)
-> ParserT# PureMode E a -> ParserT PureMode E a
forall a b. (a -> b) -> a -> b
$ \ForeignPtrContents
fpc Addr#
base Int#
os# PureMode
st0 ->
    case ParserT# PureMode E a
p ForeignPtrContents
fpc Addr#
base Int#
os# PureMode
st0 of
      Fail# PureMode
st1   -> PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
Err# PureMode
st1 (Int -> EMiddle -> E
E (Int# -> Int
I# Int#
os#) (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ EBase -> EMiddle
EBase EBase
eb)
      Err#  PureMode
st1 E
e -> PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
Err# PureMode
st1 (Int -> EMiddle -> E
E (Int# -> Int
I# Int#
os#) (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ E -> EBase -> EMiddle
EAnd E
e EBase
eb)
      Res# PureMode E a
x -> Res# PureMode E a
x