{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-} -- thanks to type manipulation

-- TODO pass metadata to parser for errors. not hard just cba

-- TODO copies a lot of stuff from generic-data-functions. some should be kept
-- in a separate library (ReifyMaybeSymbol, ProdArity, natVal'' etc.)

module Bytezap.Parser.Struct.Generic where

import Bytezap.Parser.Struct
import GHC.Generics
import GHC.Exts
import Data.Kind
import GHC.TypeNats
import GHC.TypeLits ( KnownSymbol, symbolVal' )
import Bytezap.Common.TypeNats ( natValInt )
import Bytezap.Common.Generic ( type GTFoldMapCAddition )
import DeFun.Core ( type (~>) )

class GParseBase tag where
    -- | The state token of the parser.
    type GParseBaseSt tag :: ZeroBitType
    type GParseBaseC tag a :: Constraint
    type GParseBaseE tag :: Type

    -- unlike the serializer we stay newtyped because we want our Functor
    --
    -- TODO this is where we need to pass a bunch of metadata. see gdf
    gParseBase
        :: GParseBaseC tag a
        => String       {- ^ data type name -}
        -> String       {- ^ constructor name -}
        -> Maybe String {- ^ record name (if present) -}
        -> Natural      {- ^ field index -}
        -> ParserT (GParseBaseSt tag) (GParseBaseE tag) a

    -- | Defunctionalization symbol for a type family turning 'Type's into
    --   'Natural's. (Needed as we can't partially apply type families.)
    type GParseBaseLenTF tag :: Type ~> Natural

class GParse tag gf where
    gParse :: ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)

instance GParseC tag dtName cstrName 0 gf
  => GParse tag (D1 (MetaData dtName _md2 _md3 _md4) (C1 (MetaCons cstrName _mc2 _mc3) gf)) where
    gParse :: forall (p :: k).
ParserT
  (GParseBaseSt tag)
  (GParseBaseE tag)
  (D1
     ('MetaData dtName _md2 _md3 _md4)
     (C1 ('MetaCons cstrName _mc2 _mc3) gf)
     p)
gParse = C1 ('MetaCons cstrName _mc2 _mc3) gf p
-> D1
     ('MetaData dtName _md2 _md3 _md4)
     (C1 ('MetaCons cstrName _mc2 _mc3) gf)
     p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (C1 ('MetaCons cstrName _mc2 _mc3) gf p
 -> D1
      ('MetaData dtName _md2 _md3 _md4)
      (C1 ('MetaCons cstrName _mc2 _mc3) gf)
      p)
-> (gf p -> C1 ('MetaCons cstrName _mc2 _mc3) gf p)
-> gf p
-> D1
     ('MetaData dtName _md2 _md3 _md4)
     (C1 ('MetaCons cstrName _mc2 _mc3) gf)
     p
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> gf p -> C1 ('MetaCons cstrName _mc2 _mc3) gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (gf p
 -> D1
      ('MetaData dtName _md2 _md3 _md4)
      (C1 ('MetaCons cstrName _mc2 _mc3) gf)
      p)
-> ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
-> ParserT
     (GParseBaseSt tag)
     (GParseBaseE tag)
     (D1
        ('MetaData dtName _md2 _md3 _md4)
        (C1 ('MetaCons cstrName _mc2 _mc3) gf)
        p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) (cd :: Symbol) (cc :: Symbol) (si :: Natural)
       (gf :: k -> Type) (p :: k).
GParseC tag cd cc si gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
forall {k} {k} (tag :: k) (cd :: Symbol) (cc :: Symbol)
       (si :: Natural) (gf :: k -> Type) (p :: k).
GParseC tag cd cc si gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
gParseC @tag @dtName @cstrName @0

class GParseC tag (cd :: Symbol) (cc :: Symbol) (si :: Natural) gf where
    gParseC :: ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)

instance
  ( GParseC tag cd cc si                 l
  , GParseC tag cd cc (si + ProdArity r) r
  , GParseBase tag
  , lenL ~ GTFoldMapCAddition (GParseBaseLenTF tag) l
  , KnownNat lenL
  ) => GParseC tag cd cc si (l :*: r) where
    gParseC :: forall p.
ParserT (GParseBaseSt tag) (GParseBaseE tag) ((:*:) l r p)
gParseC = Int
-> (l p -> r p -> (:*:) l r p)
-> ParserT (GParseBaseSt tag) (GParseBaseE tag) (l p)
-> ParserT (GParseBaseSt tag) (GParseBaseE tag) (r p)
-> ParserT (GParseBaseSt tag) (GParseBaseE tag) ((:*:) l r p)
forall a b c (st :: ZeroBitType) e.
Int
-> (a -> b -> c)
-> ParserT st e a
-> ParserT st e b
-> ParserT st e c
sequenceParsers Int
len l p -> r p -> (:*:) l r p
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
        (forall (tag :: k) (cd :: Symbol) (cc :: Symbol) (si :: Natural)
       (gf :: Type -> Type) p.
GParseC tag cd cc si gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
forall {k} {k} (tag :: k) (cd :: Symbol) (cc :: Symbol)
       (si :: Natural) (gf :: k -> Type) (p :: k).
GParseC tag cd cc si gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
gParseC @tag @cd @cc @si)
        (forall (tag :: k) (cd :: Symbol) (cc :: Symbol) (si :: Natural)
       (gf :: Type -> Type) p.
GParseC tag cd cc si gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
forall {k} {k} (tag :: k) (cd :: Symbol) (cc :: Symbol)
       (si :: Natural) (gf :: k -> Type) (p :: k).
GParseC tag cd cc si gf =>
ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)
gParseC @tag @cd @cc @(si + ProdArity r))
      where
        len :: Int
len = forall (n :: Natural). KnownNat n => Int
natValInt @lenL

instance
  ( GParseBase tag, GParseBaseC tag a
  , KnownNat si, ReifyMaybeSymbol mSelName, KnownSymbol cc, KnownSymbol cd
  ) => GParseC tag cd cc si (S1 (MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a)) where
    gParseC :: forall (p :: k).
ParserT
  (GParseBaseSt tag)
  (GParseBaseE tag)
  (S1 ('MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a) p)
gParseC = (Rec0 a p -> S1 ('MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a) p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (Rec0 a p -> S1 ('MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a) p)
-> (a -> Rec0 a p)
-> a
-> S1 ('MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rec0 a p
forall k i c (p :: k). c -> K1 i c p
K1) (a -> S1 ('MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a) p)
-> ParserT (GParseBaseSt tag) (GParseBaseE tag) a
-> ParserT
     (GParseBaseSt tag)
     (GParseBaseE tag)
     (S1 ('MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a) p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) a.
(GParseBase tag, GParseBaseC tag a) =>
String
-> String
-> Maybe String
-> Natural
-> ParserT (GParseBaseSt tag) (GParseBaseE tag) a
forall {k} (tag :: k) a.
(GParseBase tag, GParseBaseC tag a) =>
String
-> String
-> Maybe String
-> Natural
-> ParserT (GParseBaseSt tag) (GParseBaseE tag) a
gParseBase @tag String
cd String
cc Maybe String
cs Natural
si
      where
        cs :: Maybe String
cs = forall (mstr :: Maybe Symbol).
ReifyMaybeSymbol mstr =>
Maybe String
reifyMaybeSymbol @mSelName
        cd :: String
cd = forall (sym :: Symbol). KnownSymbol sym => String
symbolVal'' @cd
        cc :: String
cc = forall (sym :: Symbol). KnownSymbol sym => String
symbolVal'' @cc
        si :: Natural
si = forall (n :: Natural). KnownNat n => Natural
natVal'' @si

-- | Wow, look! Nothing!
instance GParseC tag cd cc 0 U1 where gParseC :: forall (p :: k).
ParserT (GParseBaseSt tag) (GParseBaseE tag) (U1 p)
gParseC = U1 p -> ParserT (GParseBaseSt tag) (GParseBaseE tag) (U1 p)
forall a (st :: ZeroBitType) e. a -> ParserT st e a
constParse U1 p
forall k (p :: k). U1 p
U1

type family ProdArity (f :: Type -> Type) :: Natural where
    ProdArity (S1 c f)  = 1
    ProdArity (l :*: r) = ProdArity l + ProdArity r

class ReifyMaybeSymbol (mstr :: Maybe Symbol) where
    reifyMaybeSymbol :: Maybe String
instance ReifyMaybeSymbol Nothing where reifyMaybeSymbol :: Maybe String
reifyMaybeSymbol = Maybe String
forall a. Maybe a
Nothing
instance KnownSymbol str => ReifyMaybeSymbol (Just str) where
    reifyMaybeSymbol :: Maybe String
reifyMaybeSymbol = String -> Maybe String
forall a. a -> Maybe a
Just (forall (sym :: Symbol). KnownSymbol sym => String
symbolVal'' @str)

natVal'' :: forall n. KnownNat n => Natural
natVal'' :: forall (n :: Natural). KnownNat n => Natural
natVal'' = Proxy# n -> Natural
forall (n :: Natural). KnownNat n => Proxy# n -> Natural
natVal' (Proxy# n
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# n)
{-# INLINE natVal'' #-}

symbolVal'' :: forall sym. KnownSymbol sym => String
symbolVal'' :: forall (sym :: Symbol). KnownSymbol sym => String
symbolVal'' = Proxy# sym -> String
forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' (Proxy# sym
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# sym)
{-# INLINE symbolVal'' #-}