Last active
July 13, 2021 18:38
-
-
Save Icelandjack/63bd76d06c265d39ffdce46293d6d67c to your computer and use it in GitHub Desktop.
Classless GHC.Generics with Type.Reflection
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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