Classless GHC.Generics with Type.Reflection

classless.hs

{-# Language EmptyCase                #-}
{-# Language GADTs                    #-}
{-# Language InstanceSigs             #-}
{-# Language PatternSynonyms          #-}
{-# Language PolyKinds                #-}
{-# Language ScopedTypeVariables      #-}
{-# Language StandaloneKindSignatures #-}
{-# Language TypeApplications         #-}
{-# Language TypeFamilies             #-}
{-# Language TypeOperators            #-}
{-# Language UndecidableInstances     #-}
{-# Language ViewPatterns             #-}

import Control.Applicative
import Control.DeepSeq
import Data.Binary hiding (gput, gget)
import Data.Functor
import Data.Kind
import GHC.Generics
import Type.Reflection
import Data.Semigroup

isU1 :: TypeRep f -> Maybe (U1 @Type :~: f)
isU1 rep = eqTypeRep (typeRep @(U1 @Type)) rep <&> \HRefl -> Refl

isV1 :: TypeRep f -> Maybe (V1 @Type :~: f)
isV1 rep = eqTypeRep (typeRep @(V1 @Type)) rep <&> \HRefl -> Refl

type ExK1 :: (k -> Type) -> Type
data ExK1 rep where
 ExK1 :: rep :~: K1 i c -> ExK1 rep

isK1 :: TypeRep rep -> Maybe (ExK1 rep)
isK1 (k1 `App` i `App` c)
 | Just HRefl <- eqTypeRep k1 (typeRep @(K1 @Type))
 = pure (ExK1 Refl)
isK1 _
 = Nothing

data ExM1 rep where
 ExM1 :: rep :~: M1 i c f -> TypeRep f -> ExM1 rep

isM1 :: TypeRep rep -> Maybe (ExM1 rep)
isM1 (m1 `App` i `App` c `App` f)
 | Just HRefl <- eqTypeRep m1 (typeRep @(M1 @Type))
 = pure (ExM1 Refl f)
isM1 _
 = Nothing

data ExProd rep where
 ExProd :: (f :*: g) :~: rep -> TypeRep f -> TypeRep g -> ExProd rep

isProd :: TypeRep rep -> Maybe (ExProd rep)
isProd (prod `App` f `App` g)
 | Just HRefl <- eqTypeRep prod (typeRep @((:*:) @Type))
 = pure (ExProd Refl f g)
isProd _
 = Nothing

data ExSum rep where
 ExSum :: (f :+: g) :~: rep -> TypeRep f -> TypeRep g -> ExSum rep

isSum :: TypeRep rep -> Maybe (ExSum rep)
isSum (sum `App` f `App` g)
 | Just HRefl <- eqTypeRep sum (typeRep @((:+:) @Type))
 = pure (ExSum Refl f g)
isSum _
 = Nothing

-- Pattern synonyms
pattern IsU1 :: () => f ~ U1 @Type => TypeRep f
pattern IsU1 <- (isU1 -> Just Refl)

pattern IsV1 :: () => f ~ V1 @Type => TypeRep f
pattern IsV1 <- (isV1 -> Just Refl)

pattern IsK1 :: forall rep. () => forall i c. K1 @Type i c ~ rep => TypeRep rep
pattern IsK1 <- (isK1 -> Just (ExK1 Refl))

pattern IsM1 :: forall rep. () => forall i c f. M1 i c f ~ rep => TypeRep f -> TypeRep rep
pattern IsM1 f <- (isM1 -> Just (ExM1 Refl f))

pattern IsProd :: forall rep. () => forall f g. rep ~ (f :*: g) => TypeRep f -> TypeRep g -> TypeRep rep
pattern IsProd f g <- (isProd -> Just (ExProd Refl f g))

pattern IsSum :: forall rep. () => forall f g. rep ~ (f :+: g) => TypeRep f -> TypeRep g -> TypeRep rep
pattern IsSum f g <- (isSum -> Just (ExSum Refl f g))

type
 AllCls :: (Type -> Constraint) -> (Type -> Type) -> Constraint
type family
 AllCls cls f where
 AllCls cls V1         = ()
 AllCls cls U1         = ()
 AllCls cls (K1 i c)   = cls c
 AllCls cls (M1 i c f) = AllCls cls f
 AllCls cls (f :*: g)  = (AllCls cls f, AllCls cls g)
 AllCls cls (f :+: g)  = (AllCls cls f, AllCls cls g)

type    Generically :: Type -> Type
newtype Generically a = Generically a

----------------------------------
-- Generic definition of NFData --
----------------------------------
grnf :: AllCls NFData f => TypeRep f -> f () -> ()
grnf IsV1         void        = case void of
grnf IsU1         U1          = ()
grnf IsK1         (K1 a)      =  rnf a
grnf (IsM1 f)     (M1 as)     = grnf f as
grnf (IsProd f g) (as :*: bs) = grnf f as `seq` grnf g bs
grnf (IsSum  f g) (L1 as)     = grnf f as
grnf (IsSum  f g) (R1 bs)     = grnf g bs

instance (AllCls NFData (Rep a), Generic a, Typeable (Rep a)) => NFData (Generically a) where
 rnf :: Generically a -> ()
 rnf (Generically a) = grnf typeRep (from a)

--------------------------------------------- 
-- Generic definition of Semigroup, Monoid --
---------------------------------------------
gmappend :: AllCls Semigroup rep => TypeRep rep -> rep () -> rep () -> rep ()
gmappend IsK1         (K1 a)      (K1 b)      = K1 (a <> b)
gmappend (IsM1 f)     (M1 as)     (M1 bs)     = M1 (gmappend f as bs)
gmappend (IsProd f g) (as1:*:bs1) (as2:*:bs2) = gmappend f as1 as2 :*: gmappend g bs1 bs2

gmempty :: AllCls Monoid rep => TypeRep rep -> rep ()
gmempty IsK1         = K1 mempty
gmempty (IsM1 f)     = M1 (gmempty f)
gmempty (IsProd f g) = gmempty f :*: gmempty g

instance (AllCls Semigroup (Rep a), Generic a, Typeable (Rep a)) => Semigroup (Generically a) where
 (<>) :: Generically a -> Generically a -> Generically a
 Generically (from -> a) <> Generically (from -> b) = Generically (to (gmappend typeRep a b))

instance (AllCls Monoid (Rep a), AllCls Semigroup (Rep a), Generic a, Typeable (Rep a)) => Monoid (Generically a) where
 mempty :: Generically a
 mempty = Generically (to (gmempty typeRep))

----------------------------------
-- Generic definition of Binary --
----------------------------------
gput :: AllCls Binary rep => TypeRep rep -> rep () -> Put
gput IsV1         _           = mempty
gput IsU1         _           = mempty
gput IsK1         (K1 a)      = put a
gput (IsM1 f)     (M1 as)     = gput f as
gput (IsProd f g) (as :*: bs) = gput f as <> gput g bs

gget :: AllCls Binary rep => TypeRep rep -> Get (rep ())
gget IsV1         = pure undefined
gget IsU1         = pure U1
gget IsK1         = K1 <$> get
gget (IsM1 f)     = M1 <$> gget f
gget (IsProd f g) = liftA2 (:*:) (gget f) (gget g)

instance (AllCls Binary (Rep a), Typeable (Rep a), Generic a) => Binary (Generically a) where
 put :: Generically a -> Put
 put (Generically a) = gput typeRep (from a)

 get :: Get (Generically a)
 get = (Generically . to) <$> gget typeRep