Skip to content

Instantly share code, notes, and snippets.

@silky

silky/Rec.hs

Forked from sjoerdvisscher/Rec.hs
Created April 12, 2021 06:02
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save silky/dc37dc1206e657bbb65b5066a6e80a6c to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save silky/dc37dc1206e657bbb65b5066a6e80a6c to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. @sjoerdvisscher sjoerdvisscher revised this gist Apr 10, 2021. 1 changed file with 16 additions and 4 deletions.
    20 changes: 16 additions & 4 deletions SameRepAs.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -7,6 +7,7 @@ module SameRepAs where
    import GHC.Generics
    import GHC.Types (Symbol, Type)
    import Generic.Data.Types ( Data )
    import GHC.TypeLits

    import Data.Coerce

    @@ -24,13 +25,24 @@ 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) (r :: Type -> Type) where
    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 (K1 i c) = K1 i c
    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)]) where
    type family OverrideFields' (typ :: Type) (fields :: [ (Symbol, Type) ]) :: Type where
    OverrideFields' typ '[] = typ
    OverrideFields' typ ('(n, t) ': fields) = ModifyField n t (OverrideFields' typ fields)
    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 "'"))
  2. @sjoerdvisscher sjoerdvisscher created this gist Apr 10, 2021.
    22 changes: 22 additions & 0 deletions Rec.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,22 @@
    {-# 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"
    36 changes: 36 additions & 0 deletions SameRepAs.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,36 @@
    {-# 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 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) (r :: 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 (K1 i c) = K1 i c
    Modify n t (l :*: r) = Modify n t l :*: Modify n t r

    type OverrideFields typ fields = typ `SameRepAs` OverrideFields' typ fields
    type family OverrideFields' (typ :: Type) (fields :: [(Symbol, Type)]) where
    OverrideFields' typ '[] = typ
    OverrideFields' typ ('(n, t) ': fields) = ModifyField n t (OverrideFields' typ fields)