{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BlockArguments #-}
module Binrep.Get
( module Binrep.Get
, module Binrep.Get.Error
) where
import Binrep.Get.Error
import Data.Functor.Identity
import Binrep.Util.ByteOrder
import Binrep.Common.Via.Prim ( ViaPrim(..) )
import Raehik.Compat.Data.Primitive.Types ( Prim', sizeOf )
import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap )
import Binrep.Get.Struct ( GetC(getC) )
import Bytezap.Parser.Struct qualified as BZ
import Binrep.CBLen ( IsCBLen(CBLen), cblen )
import GHC.TypeLits ( KnownNat )
import FlatParse.Basic qualified as FP
import Raehik.Compat.FlatParse.Basic.Prim qualified as FP
import Data.ByteString qualified as B
import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty )
import GHC.TypeLits ( TypeError )
import Data.Void
import Data.Word
import Data.Int
import GHC.Generics
import Generic.Data.Function.Traverse
import Generic.Type.Assert
import GHC.Exts ( minusAddr#, Int(I#), Int#, plusAddr#, (+#) )
import Refined
import Refined.Unsafe
type Getter a = FP.Parser E a
class Get a where
get :: Getter a
runGet :: Get a => B.ByteString -> Either E (a, B.ByteString)
runGet :: forall a. Get a => ByteString -> Either E (a, ByteString)
runGet = Getter a -> ByteString -> Either E (a, ByteString)
forall a. Getter a -> ByteString -> Either E (a, ByteString)
runGetter Getter a
forall a. Get a => Getter a
get
runGetter :: Getter a -> B.ByteString -> Either E (a, B.ByteString)
runGetter :: forall a. Getter a -> ByteString -> Either E (a, ByteString)
runGetter Getter a
g ByteString
bs = case Getter a -> ByteString -> Result E a
forall e a. Parser e a -> ByteString -> Result e a
FP.runParser Getter a
g ByteString
bs of
FP.OK a
a ByteString
bs' -> (a, ByteString) -> Either E (a, ByteString)
forall a b. b -> Either a b
Right (a
a, ByteString
bs')
Result E a
FP.Fail -> E -> Either E (a, ByteString)
forall a b. a -> Either a b
Left E
EFail
FP.Err E
e -> E -> Either E (a, ByteString)
forall a b. a -> Either a b
Left E
e
instance GenericTraverse Get where
type GenericTraverseF Get = FP.Parser E
type GenericTraverseC Get a = Get a
genericTraverseAction :: forall a.
GenericTraverseC Get a =>
String
-> String -> Maybe String -> Natural -> GenericTraverseF Get a
genericTraverseAction String
cd String
cc Maybe String
mcs Natural
si =
String -> (E -> EGeneric E) -> Getter a
forall a. Get a => String -> (E -> EGeneric E) -> Getter a
getWrapGeneric String
cd ((E -> EGeneric E) -> Getter a) -> (E -> EGeneric E) -> Getter a
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> Natural -> E -> EGeneric E
forall e. String -> Maybe String -> Natural -> e -> EGeneric e
EGenericField String
cc Maybe String
mcs Natural
si
instance GenericTraverseSum Get where
genericTraverseSumPfxTagAction :: forall pt.
GenericTraverseC Get pt =>
String -> GenericTraverseF Get pt
genericTraverseSumPfxTagAction String
cd =
String -> (E -> EGeneric E) -> Getter pt
forall a. Get a => String -> (E -> EGeneric E) -> Getter a
getWrapGeneric String
cd ((E -> EGeneric E) -> Getter pt) -> (E -> EGeneric E) -> Getter pt
forall a b. (a -> b) -> a -> b
$ EGenericSum E -> EGeneric E
forall e. EGenericSum e -> EGeneric e
EGenericSum (EGenericSum E -> EGeneric E)
-> (E -> EGenericSum E) -> E -> EGeneric E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> EGenericSum E
forall e. e -> EGenericSum e
EGenericSumTag
genericTraverseSumNoMatchingCstrAction :: forall a. String -> [String] -> Text -> GenericTraverseF Get a
genericTraverseSumNoMatchingCstrAction String
cd [String]
cstrs Text
ptText =
E -> ParserT PureMode E a
forall e (st :: ZeroBitType) a. e -> ParserT st e a
FP.err (E -> ParserT PureMode E a) -> E -> ParserT PureMode 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
$ String -> EGeneric E -> EMiddle
EGeneric String
cd (EGeneric E -> EMiddle) -> EGeneric E -> EMiddle
forall a b. (a -> b) -> a -> b
$ EGenericSum E -> EGeneric E
forall e. EGenericSum e -> EGeneric e
EGenericSum (EGenericSum E -> EGeneric E) -> EGenericSum E -> EGeneric E
forall a b. (a -> b) -> a -> b
$ [String] -> Text -> EGenericSum E
forall e. [String] -> Text -> EGenericSum e
EGenericSumTagNoMatch [String]
cstrs Text
ptText
getGenericNonSum
:: forall a
. ( Generic a, GTraverseNonSum Get (Rep a)
, GAssertNotVoid a, GAssertNotSum a
) => Getter a
getGenericNonSum :: forall a.
(Generic a, GTraverseNonSum Get (Rep a), GAssertNotVoid a,
GAssertNotSum a) =>
Getter a
getGenericNonSum = forall {k} (tag :: k) a.
(Generic a, Functor (GenericTraverseF tag),
GTraverseNonSum tag (Rep a)) =>
GenericTraverseF tag a
forall (tag :: Type -> Constraint) a.
(Generic a, Functor (GenericTraverseF tag),
GTraverseNonSum tag (Rep a)) =>
GenericTraverseF tag a
genericTraverseNonSum @Get
getGenericSum
:: forall pt a
. ( Generic a, GTraverseSum Get (Rep a)
, Get pt
, GAssertNotVoid a, GAssertSum a
) => PfxTagCfg pt -> Getter a
getGenericSum :: forall pt a.
(Generic a, GTraverseSum Get (Rep a), Get pt, GAssertNotVoid a,
GAssertSum a) =>
PfxTagCfg pt -> Getter a
getGenericSum = forall {k} (tag :: k) a pt.
(Generic a, Functor (GenericTraverseF tag),
GTraverseSum tag (Rep a), GenericTraverseC tag pt) =>
PfxTagCfg pt -> GenericTraverseF tag a
forall (tag :: Type -> Constraint) a pt.
(Generic a, Functor (GenericTraverseF tag),
GTraverseSum tag (Rep a), GenericTraverseC tag pt) =>
PfxTagCfg pt -> GenericTraverseF tag a
genericTraverseSum @Get
eBase :: EBase -> Getter a
eBase :: forall a. EBase -> Getter a
eBase EBase
eb = (ForeignPtrContents
-> Addr# -> Addr# -> PureMode -> Res# PureMode E a)
-> ParserT PureMode E a
forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
FP.ParserT \ForeignPtrContents
_fp Addr#
eob Addr#
s PureMode
st ->
let os :: Int
os = Int# -> Int
I# (Addr# -> Addr# -> Int#
minusAddr# Addr#
eob Addr#
s)
in PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
FP.Err# PureMode
st (Int -> EMiddle -> E
E Int
os (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ EBase -> EMiddle
EBase EBase
eb)
getEBase :: Getter a -> EBase -> Getter a
getEBase :: forall a. Getter a -> EBase -> Getter a
getEBase (FP.ParserT ForeignPtrContents
-> Addr# -> Addr# -> PureMode -> Res# PureMode E a
f) EBase
eb =
(ForeignPtrContents
-> Addr# -> Addr# -> PureMode -> Res# PureMode E a)
-> ParserT PureMode E a
forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
FP.ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s PureMode
st ->
let os :: Int
os = Int# -> Int
I# (Addr# -> Addr# -> Int#
minusAddr# Addr#
eob Addr#
s)
in case ForeignPtrContents
-> Addr# -> Addr# -> PureMode -> Res# PureMode E a
f ForeignPtrContents
fp Addr#
eob Addr#
s PureMode
st of
FP.Fail# PureMode
st' -> PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
FP.Err# PureMode
st' (Int -> EMiddle -> E
E Int
os (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ EBase -> EMiddle
EBase EBase
eb)
FP.Err# PureMode
st' E
e -> PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
FP.Err# PureMode
st' (Int -> EMiddle -> E
E 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
bzToFp
:: forall a e st. KnownNat (CBLen a)
=> BZ.ParserT st e a -> FP.ParserT st e a
bzToFp :: forall a e (st :: ZeroBitType).
KnownNat (CBLen a) =>
ParserT st e a -> ParserT st e a
bzToFp (BZ.ParserT ParserT# st e a
p) = Int -> ParserT st e ()
forall (st :: ZeroBitType) e. Int -> ParserT st e ()
FP.ensure (Int# -> Int
I# Int#
len#) ParserT st e () -> ParserT st e a -> ParserT st e a
forall a b. ParserT st e a -> ParserT st e b -> ParserT st e b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> ((ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
FP.ParserT ((ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a)
-> (ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
forall a b. (a -> b) -> a -> b
$ \ForeignPtrContents
fpc Addr#
_eob Addr#
s st
st0 ->
case ParserT# st e a
p ForeignPtrContents
fpc Addr#
s Int#
0# st
st0 of
BZ.OK# st
st1 a
a -> st -> a -> Addr# -> Res# st e a
forall (st :: ZeroBitType) a e. st -> a -> Addr# -> Res# st e a
FP.OK# st
st1 a
a (Addr#
s Addr# -> Int# -> Addr#
`plusAddr#` Int#
len#)
BZ.Fail# st
st1 -> st -> Res# st e a
forall (st :: ZeroBitType) e a. st -> Res# st e a
FP.Fail# st
st1
BZ.Err# st
st1 e
e -> st -> e -> Res# st e a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
FP.Err# st
st1 e
e
)
where
!(I# Int#
len#) = forall a. KnownNat (CBLen a) => Int
forall {k} (a :: k). KnownNat (CBLen a) => Int
cblen @a
fpToBz
:: FP.ParserT st e a -> Int#
-> (a -> Int# -> BZ.ParserT st e r) -> BZ.ParserT st e r
fpToBz :: forall (st :: ZeroBitType) e a r.
ParserT st e a
-> Int# -> (a -> Int# -> ParserT st e r) -> ParserT st e r
fpToBz (FP.ParserT ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
p) Int#
len# a -> Int# -> ParserT st e r
fp = ParserT# st e r -> ParserT st e r
forall (st :: ZeroBitType) e a. ParserT# st e a -> ParserT st e a
BZ.ParserT (ParserT# st e r -> ParserT st e r)
-> ParserT# st e r -> ParserT st e r
forall a b. (a -> b) -> a -> b
$ \ForeignPtrContents
fpc Addr#
base# Int#
os# st
st0 ->
case ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a
p ForeignPtrContents
fpc (Addr#
base# Addr# -> Int# -> Addr#
`plusAddr#` (Int#
os# Int# -> Int# -> Int#
+# Int#
len#)) (Addr#
base# Addr# -> Int# -> Addr#
`plusAddr#` Int#
os#) st
st0 of
FP.OK# st
st1 a
a Addr#
s ->
let unconsumed# :: Int#
unconsumed# = Addr#
s Addr# -> Addr# -> Int#
`minusAddr#` (Addr#
base# Addr# -> Int# -> Addr#
`plusAddr#` Int#
os#)
in ParserT st e r -> ParserT# st e r
forall (st :: ZeroBitType) e a. ParserT st e a -> ParserT# st e a
BZ.runParserT# (a -> Int# -> ParserT st e r
fp a
a Int#
unconsumed#) ForeignPtrContents
fpc Addr#
base# (Int#
os# Int# -> Int# -> Int#
+# Int#
unconsumed#) st
st1
FP.Fail# st
st1 -> st -> Res# st e r
forall (st :: ZeroBitType) e a. st -> Res# st e a
BZ.Fail# st
st1
FP.Err# st
st1 e
e -> st -> e -> Res# st e r
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
BZ.Err# st
st1 e
e
getWrapGeneric :: Get a => String -> (E -> EGeneric E) -> Getter a
getWrapGeneric :: forall a. Get a => String -> (E -> EGeneric E) -> Getter a
getWrapGeneric = Getter a -> String -> (E -> EGeneric E) -> Getter a
forall a. Getter a -> String -> (E -> EGeneric E) -> Getter a
getWrapGeneric' Getter a
forall a. Get a => Getter a
get
getWrapGeneric' :: Getter a -> String -> (E -> EGeneric E) -> Getter a
getWrapGeneric' :: forall a. Getter a -> String -> (E -> EGeneric E) -> Getter a
getWrapGeneric' (FP.ParserT ForeignPtrContents
-> Addr# -> Addr# -> PureMode -> Res# PureMode E a
f) String
cd E -> EGeneric E
fe =
(ForeignPtrContents
-> Addr# -> Addr# -> PureMode -> Res# PureMode E a)
-> ParserT PureMode E a
forall (st :: ZeroBitType) e a.
(ForeignPtrContents -> Addr# -> Addr# -> st -> Res# st e a)
-> ParserT st e a
FP.ParserT \ForeignPtrContents
fp Addr#
eob Addr#
s PureMode
st ->
let os :: Int
os = Int# -> Int
I# (Addr# -> Addr# -> Int#
minusAddr# Addr#
eob Addr#
s)
in case ForeignPtrContents
-> Addr# -> Addr# -> PureMode -> Res# PureMode E a
f ForeignPtrContents
fp Addr#
eob Addr#
s PureMode
st of
FP.Fail# PureMode
st' -> PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
FP.Err# PureMode
st' (Int -> EMiddle -> E
E Int
os (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ String -> EGeneric E -> EMiddle
EGeneric String
cd (EGeneric E -> EMiddle) -> EGeneric E -> EMiddle
forall a b. (a -> b) -> a -> b
$ E -> EGeneric E
fe E
EFail)
FP.Err# PureMode
st' E
e -> PureMode -> E -> Res# PureMode E a
forall (st :: ZeroBitType) e a. st -> e -> Res# st e a
FP.Err# PureMode
st' (Int -> EMiddle -> E
E Int
os (EMiddle -> E) -> EMiddle -> E
forall a b. (a -> b) -> a -> b
$ String -> EGeneric E -> EMiddle
EGeneric String
cd (EGeneric E -> EMiddle) -> EGeneric E -> EMiddle
forall a b. (a -> b) -> a -> b
$ E -> EGeneric E
fe E
e)
Res# PureMode E a
x -> Res# PureMode E a
x
newtype ViaGetC a = ViaGetC { forall a. ViaGetC a -> a
unViaGetC :: a }
instance (GetC a, KnownNat (CBLen a)) => Get (ViaGetC a) where
{-# INLINE get #-}
get :: Getter (ViaGetC a)
get = a -> ViaGetC a
forall a. a -> ViaGetC a
ViaGetC (a -> ViaGetC a) -> ParserT PureMode E a -> Getter (ViaGetC a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E a -> ParserT PureMode E a
forall a e (st :: ZeroBitType).
KnownNat (CBLen a) =>
ParserT st e a -> ParserT st e a
bzToFp ParserT PureMode E a
forall a. GetC a => GetterC a
getC
instance TypeError ENoEmpty => Get Void where get :: Getter Void
get = Getter Void
forall a. HasCallStack => a
undefined
instance TypeError ENoSum => Get (Either a b) where get :: Getter (Either a b)
get = Getter (Either a b)
forall a. HasCallStack => a
undefined
instance Get a => Get (Identity a) where get :: Getter (Identity a)
get = a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> ParserT PureMode E a -> Getter (Identity a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E a
forall a. Get a => Getter a
get
instance Get () where
{-# INLINE get #-}
get :: Getter ()
get = () -> Getter ()
forall a. a -> ParserT PureMode E a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
instance (Get l, Get r) => Get (l, r) where
{-# INLINE get #-}
get :: Getter (l, r)
get = do
l
l <- Getter l
forall a. Get a => Getter a
get
r
r <- Getter r
forall a. Get a => Getter a
get
(l, r) -> Getter (l, r)
forall a. a -> ParserT PureMode E a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (l
l, r
r)
instance Get a => Get [a] where
get :: Getter [a]
get = Getter [a]
go
where
go :: Getter [a]
go = do
Getter () -> (() -> Getter [a]) -> Getter [a] -> Getter [a]
forall (st :: ZeroBitType) e a r.
ParserT st e a
-> (a -> ParserT st e r) -> ParserT st e r -> ParserT st e r
FP.withOption Getter ()
forall (st :: ZeroBitType) e. ParserT st e ()
FP.eof (\() -> [a] -> Getter [a]
forall a. a -> ParserT PureMode E a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []) (Getter [a] -> Getter [a]) -> Getter [a] -> Getter [a]
forall a b. (a -> b) -> a -> b
$ do
a
a <- Getter a
forall a. Get a => Getter a
get
[a]
as <- Getter [a]
go
[a] -> Getter [a]
forall a. a -> ParserT PureMode E a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a] -> Getter [a]) -> [a] -> Getter [a]
forall a b. (a -> b) -> a -> b
$ a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as
instance Get B.ByteString where
{-# INLINE get #-}
get :: Getter ByteString
get = ByteString -> ByteString
B.copy (ByteString -> ByteString)
-> Getter ByteString -> Getter ByteString
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getter ByteString
forall (st :: ZeroBitType) e. ParserT st e ByteString
FP.takeRest
deriving via ViaPrim Word8 instance Get Word8
deriving via ViaPrim Int8 instance Get Int8
deriving via Word8 instance Get (ByteOrdered end Word8)
deriving via Int8 instance Get (ByteOrdered end Int8)
getPrim :: forall a. Prim' a => Getter a
getPrim :: forall a. Prim' a => Getter a
getPrim = Getter a -> EBase -> Getter a
forall a. Getter a -> EBase -> Getter a
getEBase Getter a
forall a e (st :: ZeroBitType). Prim' a => ParserT st e a
FP.anyPrim (Int -> EBase
ERanOut (a -> Int
forall a. Prim a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)))
instance Prim' a => Get (ViaPrim a) where get :: Getter (ViaPrim a)
get = a -> ViaPrim a
forall a. a -> ViaPrim a
ViaPrim (a -> ViaPrim a) -> ParserT PureMode E a -> Getter (ViaPrim a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT PureMode E a
forall a. Prim' a => Getter a
getPrim
deriving via ViaPrim (ByteOrdered 'LittleEndian a)
instance (Prim' a, ByteSwap a) => Get (ByteOrdered 'LittleEndian a)
deriving via ViaPrim (ByteOrdered 'BigEndian a)
instance (Prim' a, ByteSwap a) => Get (ByteOrdered 'BigEndian a)
instance Get (Refined pr (Refined pl a)) => Get (Refined (pl `And` pr) a) where
get :: Getter (Refined (And pl pr) a)
get = (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))
-> Getter (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. Get a => Getter a
get