GenericHasField.hs

{-# 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