{-# LANGUAGE UndecidableInstances #-} -- for Generically instance
{-# LANGUAGE OverloadedStrings #-} -- for easy error building

module Binrep.Get.Struct
  ( GetterC, GetC(getC)
  , getGenericStruct
  , runGetCBs
  , unsafeRunGetCPtr
  ) where

import Binrep.Get.Error
import Data.Text.Builder.Linear qualified as TBL
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 Rerefined.Refine
import Rerefined.Predicate.Logical.And

type GetterC = Parser (ParseError Int TBL.Builder)

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

-- | Consume 'Result'.
finishGetterC
    :: Result (ParseError Int TBL.Builder) a
    -> Either (ParseError Int TBL.Builder) a
finishGetterC :: forall a.
Result (ParseError Int Builder) a
-> Either (ParseError Int Builder) a
finishGetterC = \case
  OK  a
a -> a -> Either (ParseError Int Builder) a
forall a b. b -> Either a b
Right a
a
  Err ParseError Int Builder
e -> ParseError Int Builder -> Either (ParseError Int Builder) a
forall a b. a -> Either a b
Left  ParseError Int Builder
e
  Result (ParseError Int Builder) a
Fail  -> ParseError Int Builder -> Either (ParseError Int Builder) a
forall a b. a -> Either a b
Left  []

runGetCBs
    :: forall a. (GetC a, KnownNat (CBLen a))
    => B.ByteString -> Either (ParseError Int TBL.Builder) a
runGetCBs :: forall a.
(GetC a, KnownNat (CBLen a)) =>
ByteString -> Either (ParseError Int Builder) a
runGetCBs ByteString
bs =
    if   Int
lenReq Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lenAvail
    then Result (ParseError Int Builder) a
-> Either (ParseError Int Builder) a
forall a.
Result (ParseError Int Builder) a
-> Either (ParseError Int Builder) a
finishGetterC (Result (ParseError Int Builder) a
 -> Either (ParseError Int Builder) a)
-> Result (ParseError Int Builder) a
-> Either (ParseError Int Builder) a
forall a b. (a -> b) -> a -> b
$ ByteString
-> Parser (ParseError Int Builder) a
-> Result (ParseError Int Builder) a
forall a e. ByteString -> Parser e a -> Result e a
unsafeRunParserBs ByteString
bs Parser (ParseError Int Builder) a
forall a. GetC a => GetterC a
getC
    else ParseError Int Builder -> Either (ParseError Int Builder) a
forall a b. a -> Either a b
Left [Int -> [Builder] -> ParseErrorSingle Int Builder
forall pos text. pos -> [text] -> ParseErrorSingle pos text
ParseErrorSingle Int
0 [Builder
errMsg]]
  where
    lenReq :: Int
lenReq   = forall a. KnownNat (CBLen a) => Int
forall {k} (a :: k). KnownNat (CBLen a) => Int
cblen @a
    lenAvail :: Int
lenAvail = ByteString -> Int
B.length ByteString
bs
    errMsg :: Builder
errMsg   =
        Builder
"input too short (need "Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Int -> Builder
forall a. (Integral a, FiniteBits a) => a -> Builder
TBL.fromDec Int
lenReq
                      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Builder
", got "Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Int -> Builder
forall a. (Integral a, FiniteBits a) => a -> Builder
TBL.fromDec Int
lenAvailBuilder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Builder
")"

-- | doesn't check len
unsafeRunGetCPtr
    :: forall a. GetC a
    => Ptr Word8 -> Either (ParseError Int TBL.Builder) a
unsafeRunGetCPtr :: forall a. GetC a => Ptr Word8 -> Either (ParseError Int Builder) a
unsafeRunGetCPtr Ptr Word8
ptr = Result (ParseError Int Builder) a
-> Either (ParseError Int Builder) a
forall a.
Result (ParseError Int Builder) a
-> Either (ParseError Int Builder) a
finishGetterC (Result (ParseError Int Builder) a
 -> Either (ParseError Int Builder) a)
-> Result (ParseError Int Builder) a
-> Either (ParseError Int Builder) a
forall a b. (a -> b) -> a -> b
$ Ptr Word8
-> Parser (ParseError Int Builder) a
-> Result (ParseError Int Builder) a
forall a e. Ptr Word8 -> Parser e a -> Result e a
unsafeRunParserPtr Ptr Word8
ptr Parser (ParseError Int Builder) a
forall a. GetC a => GetterC a
getC

instance GParseBase GetC where
    type GParseBaseSt GetC = Proxy# Void
    type GParseBaseC  GetC a = GetC a
    type GParseBaseE  GetC = ParseError Int TBL.Builder
    gParseBase :: forall a.
GParseBaseC GetC a =>
String
-> String
-> Maybe String
-> Natural
-> ParserT (GParseBaseSt GetC) (GParseBaseE GetC) a
gParseBase String
dtName String
cstrName Maybe String
mFieldName Natural
fieldIdx = GetterC a
forall a. GetC a => GetterC a
getC GetterC a -> [Builder] -> GetterC a
forall (st :: ZeroBitType) text a.
ParserT st (ParseError Int text) a
-> [text] -> ParserT st (ParseError Int text) a
`cutting1` [Builder]
e
      where
        e :: [Builder]
e = String -> String -> Maybe String -> Natural -> [Builder]
parseErrorTextGenericFieldBld String
dtName String
cstrName Maybe String
mFieldName Natural
fieldIdx
    type GParseBaseLenTF GetC = CBLenSym

-- | Turn a 'Fail' into a single error, or prepend it to any existing ones.
--
-- Use when wrapping other 'get'ters.
--
-- We reimplement @cutting@ with a tweak. Otherwise, we'd have to join lists in
-- the error case (instead of simply prepending).
cutting1
    :: ParserT st (ParseError Int text) a -> [text]
    -> ParserT st (ParseError Int text) a
cutting1 :: forall (st :: ZeroBitType) text a.
ParserT st (ParseError Int text) a
-> [text] -> ParserT st (ParseError Int text) a
cutting1 (ParserT ParserT# st (ParseError Int text) a
p) [text]
texts = ParserT# st (ParseError Int text) a
-> ParserT st (ParseError Int text) a
forall (st :: ZeroBitType) e a. ParserT# st e a -> ParserT st e a
ParserT (ParserT# st (ParseError Int text) a
 -> ParserT st (ParseError Int text) a)
-> ParserT# st (ParseError Int text) a
-> ParserT st (ParseError Int text) a
forall a b. (a -> b) -> a -> b
$ \ForeignPtrContents
fpc Addr#
base# Int#
os# st
st ->
    case ParserT# st (ParseError Int text) a
p ForeignPtrContents
fpc Addr#
base# Int#
os# st
st of
      Fail# st
st'    -> st -> ParseError Int text -> Res# st (ParseError Int text) a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
Err# st
st' [Int -> [text] -> ParseErrorSingle Int text
forall pos text. pos -> [text] -> ParseErrorSingle pos text
ParseErrorSingle (Int# -> Int
I# Int#
os#) [text]
texts]
      Err#  st
st' ParseError Int text
e' -> st -> ParseError Int text -> Res# st (ParseError Int text) a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
Err# st
st' (Int -> [text] -> ParseErrorSingle Int text
forall pos text. pos -> [text] -> ParseErrorSingle pos text
ParseErrorSingle (Int# -> Int
I# Int#
os#) [text]
texts ParseErrorSingle Int text
-> ParseError Int text -> ParseError Int text
forall a. a -> [a] -> [a]
: ParseError Int text
e')
      Res# st (ParseError Int text) a
x               -> Res# st (ParseError Int text) a
x

-- | 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 (ParseError Int Builder) (Rep a Any)
-> ParserT PureMode (ParseError Int Builder) 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 (ParseError Int Builder) a
-> GetterC (Generically a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode (ParseError Int Builder) 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 (ParseError Int Builder) a
-> GetterC (GenericallyNonSum a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode (ParseError Int Builder) 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} a (p :: k). a -> Refined p a
unsafeRefine (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) a. Refined p a -> a
forall {k} (p :: k) a. Refined p a -> a
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) a. Refined p a -> a
forall {k} (p :: k) a. Refined p a -> a
unrefine @pr) (Refined pr (Refined pl a) -> Refined (And pl pr) a)
-> ParserT
     PureMode (ParseError Int Builder) (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 (ParseError Int Builder) (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 (ParseError Int Builder) a
-> GetterC (ViaPrim a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode (ParseError Int Builder) 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 (ParseError Int Builder) a
-> GetterC (Identity a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode (ParseError Int Builder) 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)

-}