{-# LANGUAGE UndecidableInstances #-}
module Binrep.Generic.Get where
import GHC.Generics
import GHC.TypeLits ( TypeError )
import Binrep.Get
import Binrep.Generic.Internal
import FlatParse.Basic qualified as FP
import FlatParse.Basic ( Parser )
import Control.Applicative ( (<|>) )
getGeneric :: (Generic a, GGet (Rep a), Get w, Eq w, Show w) => Cfg w -> Parser String a
getGeneric :: forall a w.
(Generic a, GGet (Rep a), Get w, Eq w, Show w) =>
Cfg w -> Parser String a
getGeneric Cfg w
cfg = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Parser String (Rep a Any) -> Parser String a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cfg w -> Parser String (Rep a Any)
forall {k} (f :: k -> *) w (a :: k).
(GGet f, Get w, Eq w, Show w) =>
Cfg w -> Parser String (f a)
gget Cfg w
cfg
class GGet f where
gget :: (Get w, Eq w, Show w) => Cfg w -> Parser String (f a)
instance GGet U1 where
gget :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> Parser String (U1 a)
gget Cfg w
_ = U1 a -> Parser String (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1
instance Get c => GGet (K1 i c) where
gget :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> Parser String (K1 i c a)
gget Cfg w
_ = c -> K1 i c a
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 i c a) -> Parser String c -> Parser String (K1 i c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String c
forall a. Get a => Getter a
get
instance (GGet l, GGet r) => GGet (l :*: r) where
gget :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> Parser String ((:*:) l r a)
gget Cfg w
cfg = do l a
l <- Cfg w -> Parser String (l a)
forall {k} (f :: k -> *) w (a :: k).
(GGet f, Get w, Eq w, Show w) =>
Cfg w -> Parser String (f a)
gget Cfg w
cfg
r a
r <- Cfg w -> Parser String (r a)
forall {k} (f :: k -> *) w (a :: k).
(GGet f, Get w, Eq w, Show w) =>
Cfg w -> Parser String (f a)
gget Cfg w
cfg
(:*:) l r a -> Parser String ((:*:) l r a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:*:) l r a -> Parser String ((:*:) l r a))
-> (:*:) l r a -> Parser String ((:*:) l r a)
forall a b. (a -> b) -> a -> b
$ l a
l l a -> r a -> (:*:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: r a
r
instance GGetSum (l :+: r) => GGet (l :+: r) where
gget :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> Parser String ((:+:) l r a)
gget Cfg w
cfg = do
w
tag <- Getter w
forall a. Get a => Getter a
get
case Cfg w -> w -> Maybe (Parser String ((:+:) l r a))
forall {k} (f :: k -> *) w (a :: k).
(GGetSum f, Get w, Eq w, Show w) =>
Cfg w -> w -> Maybe (Parser String (f a))
ggetsum Cfg w
cfg w
tag of
Just Parser String ((:+:) l r a)
parser -> Parser String ((:+:) l r a)
parser
Maybe (Parser String ((:+:) l r a))
Nothing -> String -> Parser String ((:+:) l r a)
forall e a. e -> Parser e a
FP.err (String -> Parser String ((:+:) l r a))
-> String -> Parser String ((:+:) l r a)
forall a b. (a -> b) -> a -> b
$ String
"invalid sum type tag: "String -> String -> String
forall a. Semigroup a => a -> a -> a
<>w -> String
forall a. Show a => a -> String
show w
tag
instance TypeError GErrRefuseVoid => GGet V1 where
gget :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> Parser String (V1 a)
gget = Cfg w -> Parser String (V1 a)
forall a. HasCallStack => a
undefined
instance GGet f => GGet (M1 i d f) where
gget :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> Parser String (M1 i d f a)
gget Cfg w
cfg = f a -> M1 i d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 i d f a)
-> Parser String (f a) -> Parser String (M1 i d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cfg w -> Parser String (f a)
forall {k} (f :: k -> *) w (a :: k).
(GGet f, Get w, Eq w, Show w) =>
Cfg w -> Parser String (f a)
gget Cfg w
cfg
class GGetSum f where
ggetsum :: (Get w, Eq w, Show w) => Cfg w -> w -> Maybe (Parser String (f a))
instance (GGetSum l, GGetSum r) => GGetSum (l :+: r) where
ggetsum :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> w -> Maybe (Parser String ((:+:) l r a))
ggetsum Cfg w
cfg w
tag = Maybe (Parser String ((:+:) l r a))
l Maybe (Parser String ((:+:) l r a))
-> Maybe (Parser String ((:+:) l r a))
-> Maybe (Parser String ((:+:) l r a))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Parser String ((:+:) l r a))
r
where
l :: Maybe (Parser String ((:+:) l r a))
l = (l a -> (:+:) l r a)
-> Parser String (l a) -> Parser String ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Parser String (l a) -> Parser String ((:+:) l r a))
-> Maybe (Parser String (l a))
-> Maybe (Parser String ((:+:) l r a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cfg w -> w -> Maybe (Parser String (l a))
forall {k} (f :: k -> *) w (a :: k).
(GGetSum f, Get w, Eq w, Show w) =>
Cfg w -> w -> Maybe (Parser String (f a))
ggetsum Cfg w
cfg w
tag
r :: Maybe (Parser String ((:+:) l r a))
r = (r a -> (:+:) l r a)
-> Parser String (r a) -> Parser String ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Parser String (r a) -> Parser String ((:+:) l r a))
-> Maybe (Parser String (r a))
-> Maybe (Parser String ((:+:) l r a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cfg w -> w -> Maybe (Parser String (r a))
forall {k} (f :: k -> *) w (a :: k).
(GGetSum f, Get w, Eq w, Show w) =>
Cfg w -> w -> Maybe (Parser String (f a))
ggetsum Cfg w
cfg w
tag
instance (GGet r, Constructor c) => GGetSum (C1 c r) where
ggetsum :: forall w (a :: k).
(Get w, Eq w, Show w) =>
Cfg w -> w -> Maybe (Parser String (C1 c r a))
ggetsum Cfg w
cfg w
tag
| w
tag w -> w -> Bool
forall a. Eq a => a -> a -> Bool
== (Cfg w -> String -> w
forall a. Cfg a -> String -> a
cSumTag Cfg w
cfg) (forall {k} (c :: k). Constructor c => String
forall (c :: Meta). Constructor c => String
conName' @c) = Parser String (C1 c r a) -> Maybe (Parser String (C1 c r a))
forall a. a -> Maybe a
Just (Parser String (C1 c r a) -> Maybe (Parser String (C1 c r a)))
-> Parser String (C1 c r a) -> Maybe (Parser String (C1 c r a))
forall a b. (a -> b) -> a -> b
$ Cfg w -> Parser String (C1 c r a)
forall {k} (f :: k -> *) w (a :: k).
(GGet f, Get w, Eq w, Show w) =>
Cfg w -> Parser String (f a)
gget Cfg w
cfg
| Bool
otherwise = Maybe (Parser String (C1 c r a))
forall a. Maybe a
Nothing