{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:(

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)

-- | Empty constructor.
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

-- | Field.
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

-- | Product type fields are consecutive.
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

-- | Constructor sums are differentiated by a prefix tag.
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

-- | Refuse to derive instance for void datatype.
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

-- | Any datatype, constructor or record.
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

-- | Bad. Need to wrap this like SumFromString in Aeson.
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