Rec.hs

{-# LANGUAGE DerivingStrategies, DerivingVia, TypeOperators, DataKinds,
             DeriveGeneric #-}

module Rec where

import SameRepAs
import GHC.Generics ( Generic )

import qualified Data.Monoid as M

data Rec1 = Rec1 {a :: Bool, b :: Int}
  deriving stock (Show, Generic)
  deriving (Semigroup, Monoid) via OverrideFields Rec1 '[ '("a", M.Any), '("b", M.Sum Int) ]

data Rec2 = Rec2 {c :: Int, d :: Bool, e :: String}
  deriving stock (Show, Generic)
  deriving (Semigroup, Monoid) via OverrideFields Rec2 '[ '("d", M.Any), '("c", M.Product Int) ]

rec1 :: Rec1
rec1 = Rec1 True 1
rec2 :: Rec2
rec2 = Rec2 3 False "hi"

SameRepAs.hs

{-# LANGUAGE ScopedTypeVariables, TypeApplications, TypeOperators,
             FlexibleContexts, ConstraintKinds, DataKinds,
             TypeFamilies, UndecidableInstances #-}

module SameRepAs where

import GHC.Generics
import GHC.Types (Symbol, Type)
import Generic.Data.Types ( Data )
import GHC.TypeLits

import Data.Coerce

newtype SameRepAs a b = SameRepAs a

type HasSameRepAs a b = ( Generic a, Generic b, Coercible (Rep a ()) (Rep b ()) )

coerceViaRep :: forall a b. a `HasSameRepAs` b => a -> b
coerceViaRep = to . (coerce :: Rep a () -> Rep b ()) . from

instance ( a `HasSameRepAs` b, Semigroup b ) => Semigroup (a `SameRepAs` b) where
  SameRepAs l <> SameRepAs r = SameRepAs $ coerceViaRep @b (coerceViaRep l <> coerceViaRep r)

instance ( a `HasSameRepAs` b, Monoid b ) => Monoid (a `SameRepAs` b) where
  mempty = SameRepAs $ coerceViaRep @b mempty

type ModifyField name typ a = Data (Modify name typ (Rep a)) ()
type family Modify (name :: Symbol) (typ :: Type) (rep :: Type -> Type) :: Type -> Type where
  Modify n t (S1 ('MetaSel ('Just n) a b c) (Rec0 _t)) = S1 ('MetaSel ('Just n) a b c) (Rec0 t)
  Modify n t (M1 i c f) = M1 i c (Modify n t f)
  Modify n t (l :*: r) = Modify n t l :*: Modify n t r
  Modify n t (l :+: r) = Modify n t l :+: Modify n t r
  Modify n t rep = rep

type family IfContainsField (name :: Symbol) (f :: Type -> Type) (t :: Type) (e :: Type) :: Type where
  IfContainsField n (S1 ('MetaSel ('Just n) a b c) f) t e = t
  IfContainsField n (l :*: r) t e = IfContainsField n l t (IfContainsField n r t e)
  IfContainsField n (l :+: r) t e = IfContainsField n l (IfContainsField n r t e) e
  IfContainsField n (M1 i c f) t e = IfContainsField n f t e
  IfContainsField n f t e = e

type OverrideFields typ fields = typ `SameRepAs` OverrideFields' typ fields
type family OverrideFields' (typ :: Type) (fields :: [ (Symbol, Type) ]) :: Type where
  OverrideFields' typ '[] = typ
  OverrideFields' typ ('(n, t) ': fields) =
    IfContainsField n (Rep typ)
      (ModifyField n t (OverrideFields' typ fields))
      (TypeError ('Text "Type " :<>: ShowType typ :<>: 'Text " does not have a field named '" :<>: 'Text n :<>: 'Text "'"))