Skip to content

Instantly share code, notes, and snippets.

@Icelandjack
Last active Jul 13, 2021
Embed
What would you like to do?
Classless GHC.Generics with Type.Reflection
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment