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

{- TODO
* in some low-level Haskell code (probably bytestring or other GHC lib) I've
  seen a pattern of binding in a certain way in order to hint a value's
  stickiness (whether it will change) to GHC. Probably whether to put it on LHS
  or RHS.
  * yeah, I think see https://wiki.haskell.org/Let_vs._Where
  * and Data.ByteString.Builder.Internal for a purposeful eta expansion
-}

{- | Generics for bytezap's struct serializer.

We can't use my generic-data-functions library, because we're doing more than
just basic monoidal composition. But I still want the same pluggable generics,
where the user provides the class to use for base cases. So I do that. However,
unlike g-d-f, the class info can't be provided via the user-selected monoid,
because you don't select that. Instead, we take a simple "index" type. It's
pretty much the same idea, surprisingly. This way, we can provide a few sensible
"versions" like in g-f-d, while primarily designing for DIY.
-}

module Bytezap.Struct.Generic where

import Bytezap.Struct
import GHC.Generics
import GHC.Exts
import Bytezap.Common.Generic ( type GTFoldMapCAddition )
import Bytezap.Common.TypeNats ( natValInt )
import Data.Kind
import GHC.TypeNats
import DeFun.Core ( type (~>) )

-- | Class for holding info on class to use for poking base cases.
--
-- The type is just used to map to class info. It is never instantiated.
-- By packing @KnownSizeOf@ into here, we don't need to enforce a type-level
-- solution! Now it's up to you how you want to track your constant lengths.
--
-- We stay unboxed here because the internals are unboxed, just for convenience.
-- Maybe this is bad, let me know.
class GPokeBase tag where
    -- | The state token of our poker.
    type GPokeBaseSt tag

    -- | The type class that provides base case poking.
    --
    -- The type class should provide a function that looks like 'gPokeBase'.
    type GPokeBaseC tag a :: Constraint

    gPokeBase :: GPokeBaseC tag a => a -> Poke# (GPokeBaseSt tag)

    type GPokeBaseLenTF tag :: Type ~> Natural

class GPoke tag f where gPoke :: f p -> Poke# (GPokeBaseSt tag)

instance GPoke tag f => GPoke tag (D1 c f) where gPoke :: forall (p :: k). D1 c f p -> Poke# (GPokeBaseSt tag)
gPoke = forall (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
gPoke @tag (f p -> Poke# (GPokeBaseSt tag))
-> (D1 c f p -> f p) -> D1 c f p -> Poke# (GPokeBaseSt tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 c f p -> f p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1
instance GPoke tag f => GPoke tag (C1 c f) where gPoke :: forall (p :: k). C1 c f p -> Poke# (GPokeBaseSt tag)
gPoke = forall (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
gPoke @tag (f p -> Poke# (GPokeBaseSt tag))
-> (C1 c f p -> f p) -> C1 c f p -> Poke# (GPokeBaseSt tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 c f p -> f p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1

instance
  ( GPoke tag l
  , GPoke tag r
  , GPokeBase tag
  , lenL ~ GTFoldMapCAddition (GPokeBaseLenTF tag) l
  , KnownNat lenL
  ) => GPoke tag (l :*: r) where
    -- TODO moved os and s0 to RHS because base is const and those aren't?
    -- will this change anything?? idk!!!!
    gPoke :: forall (p :: k). (:*:) l r p -> Poke# (GPokeBaseSt tag)
gPoke (l p
l :*: r p
r) Addr#
base# = \Int#
os# State# (GPokeBaseSt tag)
s0 ->
        case forall (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
gPoke @tag l p
l Addr#
base# Int#
os# State# (GPokeBaseSt tag)
s0 of
          State# (GPokeBaseSt tag)
s1 -> forall (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GPoke tag f =>
f p -> Poke# (GPokeBaseSt tag)
gPoke @tag r p
r Addr#
base# (Int#
os# Int# -> Int# -> Int#
+# Int#
lenL#) State# (GPokeBaseSt tag)
s1
      where
        !(I# Int#
lenL#) = forall (n :: Natural). KnownNat n => Int
natValInt @lenL

instance (GPokeBase tag, GPokeBaseC tag a) => GPoke tag (S1 c (Rec0 a)) where
    gPoke :: forall (p :: k). S1 c (Rec0 a) p -> Poke# (GPokeBaseSt tag)
gPoke = forall (tag :: k) a.
(GPokeBase tag, GPokeBaseC tag a) =>
a -> Poke# (GPokeBaseSt tag)
forall {k} (tag :: k) a.
(GPokeBase tag, GPokeBaseC tag a) =>
a -> Poke# (GPokeBaseSt tag)
gPokeBase @tag (a -> Poke# (GPokeBaseSt tag))
-> (S1 c (Rec0 a) p -> a)
-> S1 c (Rec0 a) p
-> Poke# (GPokeBaseSt tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R a p -> a
forall k i c (p :: k). K1 i c p -> c
unK1 (K1 R a p -> a)
-> (S1 c (Rec0 a) p -> K1 R a p) -> S1 c (Rec0 a) p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 c (Rec0 a) p -> K1 R a p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1

-- | Wow, look! Nothing!
instance GPoke tag U1 where gPoke :: forall (p :: k). U1 p -> Poke# (GPokeBaseSt tag)
gPoke U1 p
U1 Addr#
_base# = \Int#
_os# State# (GPokeBaseSt tag)
s0 -> State# (GPokeBaseSt tag)
s0