{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
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.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 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 GFoldMapSumConsByte m V1 where
gFoldMapSumConsByte :: forall (p :: k). (Word8 -> m) -> V1 p -> m
gFoldMapSumConsByte Word8 -> m
_ = forall a. HasCallStack => a
undefined
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)
#elif __GLASGOW_HASKELL__ < 800
TypeErrorMessage a = a ~ ""
#endif