{-# 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 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 #-}

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)