{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6
{-# LANGUAGE AllowAmbiguousTypes #-} -- due to type class design
{-# LANGUAGE CPP #-} -- due to TypeErrorMessage hack

{- | 'foldMap' for sum types, where constructors are encoded by index
     (distance from first/leftmost constructor) in a single byte, which is
     prepended to their contents.

TODO. Clumsy and limited. And yet, still handy enough I think.
-}

module Generic.Data.Function.FoldMap.SumConsByte where

import GHC.Generics
import GHC.TypeLits
import Data.Kind ( Type, Constraint )
import Generic.Data.Function.Common.TypeLits ( natVal'' )
import Generic.Data.Function.FoldMap.Constructor
  ( GFoldMapC(gFoldMapC)
  , GenericFoldMap(type GenericFoldMapM) )

import Data.Word ( Word8 )

class GFoldMapSumConsByte tag f where
    gFoldMapSumConsByte
        :: (Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag

instance GFoldMapSumConsByte tag f => GFoldMapSumConsByte tag (D1 c f) where
    gFoldMapSumConsByte :: forall (p :: k).
(Word8 -> GenericFoldMapM tag) -> D1 c f p -> GenericFoldMapM tag
gFoldMapSumConsByte Word8 -> GenericFoldMapM tag
f (M1 f p
a) = forall (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapSumConsByte tag f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapSumConsByte tag f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
gFoldMapSumConsByte @tag Word8 -> GenericFoldMapM tag
f f p
a

instance
  ( FitsInByte (SumArity (l :+: r))
  , GFoldMapCSumCtrArityByte tag 0 (l :+: r)
  , GFoldMapCSumCtr tag (l :+: r)
  , Semigroup (GenericFoldMapM tag)
  ) => GFoldMapSumConsByte tag (l :+: r) where
    gFoldMapSumConsByte :: forall p.
(Word8 -> GenericFoldMapM tag)
-> (:+:) l r p -> GenericFoldMapM tag
gFoldMapSumConsByte Word8 -> GenericFoldMapM tag
f (:+:) l r p
lr =
        forall (tag :: k) (arity :: Natural) (f :: Type -> Type) p.
GFoldMapCSumCtrArityByte tag arity f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (arity :: Natural) (f :: k -> Type)
       (p :: k).
GFoldMapCSumCtrArityByte tag arity f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
gFoldMapCSumCtrArityByte @tag @0 Word8 -> GenericFoldMapM tag
f (:+:) l r p
lr GenericFoldMapM tag -> GenericFoldMapM tag -> GenericFoldMapM tag
forall a. Semigroup a => a -> a -> a
<> forall (tag :: k) (f :: Type -> Type) p.
GFoldMapCSumCtr tag f =>
f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapCSumCtr tag f =>
f p -> GenericFoldMapM tag
gFoldMapCSumCtr @tag (:+:) l r p
lr

instance GFoldMapSumConsByte m (C1 c f) where
    gFoldMapSumConsByte :: forall (p :: k).
(Word8 -> GenericFoldMapM m) -> C1 c f p -> GenericFoldMapM m
gFoldMapSumConsByte Word8 -> GenericFoldMapM m
_ = C1 c f p -> GenericFoldMapM m
forall a. HasCallStack => a
undefined

instance GFoldMapSumConsByte m V1 where
    gFoldMapSumConsByte :: forall (p :: k).
(Word8 -> GenericFoldMapM m) -> V1 p -> GenericFoldMapM m
gFoldMapSumConsByte Word8 -> GenericFoldMapM m
_ = V1 p -> GenericFoldMapM m
forall a. HasCallStack => a
undefined

---

-- | Sum type handler handling constructors only. Useful if you handle
--   constructor prefixes elsewhere.
class GFoldMapCSumCtr tag f where gFoldMapCSumCtr :: f p -> GenericFoldMapM tag

instance (GFoldMapCSumCtr tag l, GFoldMapCSumCtr tag r)
  => GFoldMapCSumCtr tag (l :+: r) where
    gFoldMapCSumCtr :: forall (p :: k). (:+:) l r p -> GenericFoldMapM tag
gFoldMapCSumCtr = \case L1 l p
l -> forall (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapCSumCtr tag f =>
f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapCSumCtr tag f =>
f p -> GenericFoldMapM tag
gFoldMapCSumCtr @tag l p
l
                            R1 r p
r -> forall (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapCSumCtr tag f =>
f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapCSumCtr tag f =>
f p -> GenericFoldMapM tag
gFoldMapCSumCtr @tag r p
r

instance GFoldMapC tag f => GFoldMapCSumCtr tag (C1 c f) where
    gFoldMapCSumCtr :: forall (p :: k). C1 c f p -> GenericFoldMapM tag
gFoldMapCSumCtr (M1 f p
a) = forall (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapC tag f =>
f p -> GenericFoldMapM tag
forall {k} {k1} (tag :: k) (f :: k1 -> Type) (p :: k1).
GFoldMapC tag f =>
f p -> GenericFoldMapM tag
gFoldMapC @tag f p
a

---

class GFoldMapCSumCtrArityByte tag (arity :: Natural) f where
    gFoldMapCSumCtrArityByte
        :: (Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag

instance
  ( GFoldMapCSumCtrArityByte tag arity l
  , GFoldMapCSumCtrArityByte tag (arity + SumArity l) r
  ) => GFoldMapCSumCtrArityByte tag arity (l :+: r) where
    gFoldMapCSumCtrArityByte :: forall p.
(Word8 -> GenericFoldMapM tag)
-> (:+:) l r p -> GenericFoldMapM tag
gFoldMapCSumCtrArityByte Word8 -> GenericFoldMapM tag
f = \case
      L1 l p
l -> forall (tag :: k) (arity :: Natural) (f :: Type -> Type) p.
GFoldMapCSumCtrArityByte tag arity f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (arity :: Natural) (f :: k -> Type)
       (p :: k).
GFoldMapCSumCtrArityByte tag arity f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
gFoldMapCSumCtrArityByte @tag @arity                Word8 -> GenericFoldMapM tag
f l p
l
      R1 r p
r -> forall (tag :: k) (arity :: Natural) (f :: Type -> Type) p.
GFoldMapCSumCtrArityByte tag arity f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (arity :: Natural) (f :: k -> Type)
       (p :: k).
GFoldMapCSumCtrArityByte tag arity f =>
(Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag
gFoldMapCSumCtrArityByte @tag @(arity + SumArity l) Word8 -> GenericFoldMapM tag
f r p
r

instance KnownNat arity => GFoldMapCSumCtrArityByte tag arity (C1 c f) where
    gFoldMapCSumCtrArityByte :: forall (p :: k).
(Word8 -> GenericFoldMapM tag) -> C1 c f p -> GenericFoldMapM tag
gFoldMapCSumCtrArityByte Word8 -> GenericFoldMapM tag
f C1 c f p
_ = Word8 -> GenericFoldMapM tag
f (Natural -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Natural). KnownNat n => Natural
natVal'' @arity))

---

type family SumArity (a :: Type -> Type) :: Natural where
    SumArity (C1 c a) = 1
    SumArity (x :+: y) = SumArity x + SumArity y

type FitsInByte n = FitsInByteResult (n <=? 255)

type family FitsInByteResult (b :: Bool) :: Constraint where
    FitsInByteResult 'True = ()
    FitsInByteResult 'False = TypeErrorMessage
        "TODO ya type had more than 255 constructors"

type family TypeErrorMessage (a :: Symbol) :: Constraint where
#if MIN_VERSION_base(4,9,0)
    TypeErrorMessage a = TypeError ('Text a)
-- GHC < 8.0 does not support empty closed type families
#elif __GLASGOW_HASKELL__ < 800
    TypeErrorMessage a = a ~ ""
#endif