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

-- | Refuse to derive instance for empty data types.
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

-- | TODO: Non-sum data types.
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))

-- | The empty constructor trivially succeeds without parsing anything.
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

--------------------------------------------------------------------------------

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

-- | TODO: Want to return an @Either [(String, Text)]@ indicating the
-- constructors and their expected tags tested, but needs fiddling (can't use
-- 'Alternative'). Pretty minor, but Aeson does it and it's nice.
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