{-# 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.Util.TypeNats ( natVal'' )
import Generic.Data.Function.Error ( type ENoEmpty, type EUnexpectedNonSum )
import Generic.Data.Function.FoldMap.Constructor ( GFoldMapC(gFoldMapC) )

import Data.Word ( Word8 )

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

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

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

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

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

---

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

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

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

---

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

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

instance KnownNat arity => GFoldMapCSumCtrArityByte m arity (C1 c f) where
    gFoldMapCSumCtrArityByte :: forall (p :: k). (Word8 -> m) -> C1 c f p -> m
gFoldMapCSumCtrArityByte Word8 -> m
f C1 c f p
_ = Word8 -> m
f (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