{-# LANGUAGE UndecidableInstances #-}
module Binrep.Generic.Get where
import GHC.Generics
import GHC.TypeLits ( TypeError )
import Binrep.Get
import Binrep.Generic.Internal
import Util.Generic
import FlatParse.Basic qualified as FP
import Control.Applicative ( (<|>) )
import Numeric.Natural
getGeneric :: (Generic a, GGetD (Rep a), Get w) => Cfg w -> Getter a
getGeneric :: forall a w. (Generic a, GGetD (Rep a), Get w) => Cfg w -> Getter a
getGeneric Cfg w
cfg = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) w (a :: k).
(GGetD f, Get w) =>
Cfg w -> Getter (f a)
ggetD Cfg w
cfg
class GGetD f where
ggetD :: Get w => Cfg w -> Getter (f a)
instance (GGetC f, Datatype d) => GGetD (D1 d f) where
ggetD :: forall w (a :: k). Get w => Cfg w -> Getter (D1 d f a)
ggetD Cfg w
cfg = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) w (a :: k).
(GGetC f, Get w) =>
Cfg w -> String -> Getter (f a)
ggetC Cfg w
cfg (forall {k} (d :: k). Datatype d => String
datatypeName' @d)
class GGetC f where
ggetC :: Get w => Cfg w -> String -> Getter (f a)
instance TypeError GErrRefuseVoid => GGetC V1 where
ggetC :: forall w (a :: k). Get w => Cfg w -> String -> Getter (V1 a)
ggetC = forall a. HasCallStack => a
undefined
instance (GGetS f, Constructor c) => GGetC (C1 c f) where
ggetC :: forall w (a :: k). Get w => Cfg w -> String -> Getter (C1 c f a)
ggetC Cfg w
cfg String
dStr = (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) w (a :: k).
(GGetS f, Get w) =>
Cfg w -> String -> String -> Natural -> Getter (Natural, f a)
ggetS Cfg w
cfg String
dStr (forall {k} (c :: k). Constructor c => String
conName' @c) Natural
0
class GGetS f where
ggetS :: Get w => Cfg w -> String -> String -> Natural -> Getter (Natural, (f a))
instance GGetS U1 where
ggetS :: forall w (a :: k).
Get w =>
Cfg w -> String -> String -> Natural -> Getter (Natural, U1 a)
ggetS Cfg w
_ String
_ String
_ Natural
fIdx = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
fIdx, forall k (p :: k). U1 p
U1)
instance (GGetS l, GGetS r) => GGetS (l :*: r) where
ggetS :: forall w (a :: k).
Get w =>
Cfg w
-> String -> String -> Natural -> Getter (Natural, (:*:) l r a)
ggetS Cfg w
cfg String
dStr String
cStr Natural
fIdx = do
(Natural
fIdx', l a
l) <- forall {k} (f :: k -> *) w (a :: k).
(GGetS f, Get w) =>
Cfg w -> String -> String -> Natural -> Getter (Natural, f a)
ggetS Cfg w
cfg String
dStr String
cStr Natural
fIdx
(Natural
fIdx'', r a
r) <- forall {k} (f :: k -> *) w (a :: k).
(GGetS f, Get w) =>
Cfg w -> String -> String -> Natural -> Getter (Natural, f a)
ggetS Cfg w
cfg String
dStr String
cStr (Natural
fIdx'forall a. Num a => a -> a -> a
+Natural
1)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
fIdx'', l a
l forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: r a
r)
instance (Get a, Selector s) => GGetS (S1 s (Rec0 a)) where
ggetS :: forall w (a :: k).
Get w =>
Cfg w
-> String -> String -> Natural -> Getter (Natural, S1 s (Rec0 a) a)
ggetS Cfg w
_ String
dStr String
cStr Natural
fIdx = do
a
a <- forall a. Get a => (E -> E) -> Getter a
getEWrap forall a b. (a -> b) -> a -> b
$ String -> EGeneric -> E
EGeneric String
dStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> Natural -> E -> EGeneric
EGenericField String
cStr Maybe String
sStr Natural
fIdx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
fIdx, forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall k i c (p :: k). c -> K1 i c p
K1 a
a))
where
sStr :: Maybe String
sStr = forall {k} (s :: k). Selector s => Maybe String
selName'' @s
instance GGetCSum (l :+: r) => GGetC (l :+: r) where
ggetC :: forall w (a :: k). Get w => Cfg w -> String -> Getter ((:+:) l r a)
ggetC Cfg w
cfg String
dStr = do
w
tag <- forall a. Get a => (E -> E) -> Getter a
getEWrap forall a b. (a -> b) -> a -> b
$ String -> EGeneric -> E
EGeneric String
dStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. EGenericSum -> EGeneric
EGenericSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> EGenericSum
EGenericSumTag
case forall {k} (f :: k -> *) w (a :: k).
(GGetCSum f, Get w) =>
Cfg w -> String -> w -> Maybe (Getter (f a))
ggetCSum Cfg w
cfg String
dStr w
tag of
Just Getter ((:+:) l r a)
parser -> Getter ((:+:) l r a)
parser
Maybe (Getter ((:+:) l r a))
Nothing -> do
let tagPretty :: Text
tagPretty = forall a. Cfg a -> a -> Text
cSumTagShow Cfg w
cfg forall a b. (a -> b) -> a -> b
$ w
tag
forall e a. e -> Parser e a
FP.err forall a b. (a -> b) -> a -> b
$ String -> EGeneric -> E
EGeneric String
dStr forall a b. (a -> b) -> a -> b
$ EGenericSum -> EGeneric
EGenericSum forall a b. (a -> b) -> a -> b
$ [String] -> Text -> EGenericSum
EGenericSumTagNoMatch [] Text
tagPretty
class GGetCSum f where
ggetCSum :: Get w => Cfg w -> String -> w -> Maybe (Getter (f a))
instance (GGetCSum l, GGetCSum r) => GGetCSum (l :+: r) where
ggetCSum :: forall w (a :: k).
Get w =>
Cfg w -> String -> w -> Maybe (Getter ((:+:) l r a))
ggetCSum Cfg w
cfg String
dStr w
tag = Maybe (Getter ((:+:) l r a))
l forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Getter ((:+:) l r a))
r
where
l :: Maybe (Getter ((:+:) l r a))
l = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) w (a :: k).
(GGetCSum f, Get w) =>
Cfg w -> String -> w -> Maybe (Getter (f a))
ggetCSum Cfg w
cfg String
dStr w
tag
r :: Maybe (Getter ((:+:) l r a))
r = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) w (a :: k).
(GGetCSum f, Get w) =>
Cfg w -> String -> w -> Maybe (Getter (f a))
ggetCSum Cfg w
cfg String
dStr w
tag
instance (GGetS f, Constructor c) => GGetCSum (C1 c f) where
ggetCSum :: forall w (a :: k).
Get w =>
Cfg w -> String -> w -> Maybe (Getter (C1 c f a))
ggetCSum Cfg w
cfg String
dStr w
tag =
let cStr :: String
cStr = forall {k} (c :: k). Constructor c => String
conName' @c
cTag :: w
cTag = (forall a. Cfg a -> String -> a
cSumTag Cfg w
cfg) String
cStr
in if (forall a. Cfg a -> a -> a -> Bool
cSumTagEq Cfg w
cfg) w
tag w
cTag
then forall a. a -> Maybe a
Just ((forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) w (a :: k).
(GGetS f, Get w) =>
Cfg w -> String -> String -> Natural -> Getter (Natural, f a)
ggetS Cfg w
cfg String
dStr String
cStr Natural
0)
else forall a. Maybe a
Nothing