Skip to content

Instantly share code, notes, and snippets.

@silky
Forked from sjoerdvisscher/Rec.hs
Created April 12, 2021 06:02
Show Gist options
  • Save silky/dc37dc1206e657bbb65b5066a6e80a6c to your computer and use it in GitHub Desktop.
Save silky/dc37dc1206e657bbb65b5066a6e80a6c to your computer and use it in GitHub Desktop.
{-# 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"
{-# 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 "'"))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment