Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# LANGUAGE AllowAmbiguousTypes
, DataKinds
, DeriveGeneric
, DuplicateRecordFields
, FlexibleContexts
, FlexibleInstances
, KindSignatures
, MultiParamTypeClasses
, ScopedTypeVariables
, TypeApplications
, TypeFamilies
, TypeOperators
, UndecidableInstances
#-}
module GenericHasField where
import GHC.Generics
import GHC.TypeLits
import Data.Proxy
data T = MkT { bar :: Bool, foo :: Int }
deriving Generic
data U = MkU1 { foo :: Int } | MkU2 { bar :: Bool }
deriving Generic
x = genericGetField @"foo" (MkT True 42)
y = genericGetField @"foo" (MkU1 2)
z1 = genericGetField @"bar" (MkU2 True)
z2 = genericGetField @"bar" (MkU1 2)
genericGetField :: forall x s a . (GHasField x a (Rep s), Generic s) => s -> a
genericGetField = ggetField @x . from
class GHasField (x :: Symbol) a f where
ggetField :: f p -> a
instance GHasField x a f => GHasField x a (M1 D c f) where
ggetField (M1 z) = ggetField @x z
instance GHasField x a f => GHasField x a (M1 C c f) where
ggetField (M1 z) = ggetField @x z
instance GHasFieldSum x a f g (ContainsField x f) (ContainsField x g) => GHasField x a (f :+: g) where
ggetField = ggetFieldSum @x
instance GHasFieldProd x a f g (ContainsField x f) => GHasField x a (f :*: g) where
ggetField = ggetFieldProd @x
instance a ~ a' => GHasField x a (M1 S ('MetaSel ('Just x) u0 u1 u2) (Rec0 a')) where
ggetField (M1 (K1 t)) = t
type family ContainsField x f where
ContainsField x U1 = False
ContainsField x V1 = False
ContainsField x (S1 ('MetaSel ('Just x) _ _ _) _) = True
ContainsField x (S1 ('MetaSel _ _ _ _) _) = False
ContainsField x (D1 m f) = ContainsField x f
ContainsField x (C1 m f) = ContainsField x f
ContainsField x (f :+: g) = ContainsField x f || ContainsField x g
ContainsField x (f :*: g) = ContainsField x f || ContainsField x g
ContainsField x (Rec0 _) = False
ContainsField x t = TypeError (ShowType t)
type family a || b where
True || b = True
False || b = b
class inl ~ ContainsField x f => GHasFieldProd x a f g inl where
ggetFieldProd :: (f :*: g) p -> a
instance (GHasField x a f, ContainsField x f ~ True) => GHasFieldProd x a f g True where
ggetFieldProd (z1 :*: z2) = ggetField @x z1
instance (GHasField x a g, ContainsField x f ~ False) => GHasFieldProd x a f g False where
ggetFieldProd (z1 :*: z2) = ggetField @x z2
class (inl ~ ContainsField x f, inr ~ ContainsField x g) => GHasFieldSum x a f g inl inr where
ggetFieldSum :: (f :+: g) p -> a
instance (GHasField x a f, ContainsField x f ~ True, ContainsField x g ~ False, KnownSymbol x)
=> GHasFieldSum x a f g True False where
ggetFieldSum (L1 z) = ggetField @x z
ggetFieldSum (R1 z) = error ("No match in record selector " ++ symbolVal (Proxy :: Proxy x))
instance (GHasField x a g, ContainsField x f ~ False, ContainsField x g ~ True, KnownSymbol x)
=> GHasFieldSum x a f g False True where
ggetFieldSum (L1 z) = error ("No match in record selector " ++ symbolVal (Proxy :: Proxy x))
ggetFieldSum (R1 z) = ggetField @x z
instance (GHasField x a f, GHasField x a g, ContainsField x f ~ True, ContainsField x g ~ True)
=> GHasFieldSum x a f g True True where
ggetFieldSum (L1 z) = ggetField @x z
ggetFieldSum (R1 z) = ggetField @x z
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.