Skip to content

Instantly share code, notes, and snippets.

Show Gist options
  • Save klapaucius/f2d0616503b57413a32dd39c62fc45e9 to your computer and use it in GitHub Desktop.
Save klapaucius/f2d0616503b57413a32dd39c62fc45e9 to your computer and use it in GitHub Desktop.
{-# LANGUAGE RankNTypes, TypeInType, TypeApplications, OverloadedLabels,
ScopedTypeVariables, TypeOperators, GADTs, FlexibleInstances, FlexibleContexts,
TypeFamilies, UndecidableInstances #-}
import Data.Kind (Type)
import Data.Proxy (Proxy(..))
import GHC.Generics
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Control.Lens
import Data.Generics.Product.Fields (field')
import Data.Generics.Labels ()
data Field a = Symbol ::: a
data Rec (ts :: [Field Type]) where
EmptyRec :: Rec '[]
WithField :: forall name a ts. a -> Rec ts -> Rec (name ::: a : ts)
instance Generic (Rec '[name ::: a]) where
type Rep (Rec '[name ::: a]) =
(D1 (MetaData "" "" "" 'False)
(C1 (MetaCons "" 'PrefixI 'True)
(S1 (MetaSel ('Just name) NoSourceUnpackedness NoSourceStrictness DecidedLazy)
(Rec0 a))))
from (WithField x EmptyRec) = M1 (M1 (M1 (K1 x)))
to (M1 (M1 (M1 (K1 x)))) = WithField x EmptyRec
type family AddField f rep where
AddField f (D1 dmeta (C1 cmeta sel)) = D1 dmeta (C1 cmeta (f :*: sel))
instance
( Generic (Rec (t:ts))
, Rep (Rec (t:ts)) ~ D1 dmeta (C1 cmeta sel)
) => Generic (Rec (name ::: a : t:ts)) where
type Rep (Rec (name ::: a : t:ts)) =
AddField
(S1 (MetaSel ('Just name) NoSourceUnpackedness NoSourceStrictness DecidedLazy)
(Rec0 a))
(Rep (Rec (t:ts)))
from (WithField x next) =
let M1 (M1 next') = GHC.Generics.from next
in M1 (M1 (M1 (K1 x) :*: next'))
to (M1 (M1 (M1 (K1 x) :*: next'))) =
let next = GHC.Generics.to (M1 (M1 next'))
in WithField x next
instance Show (Rec '[]) where show EmptyRec = "{}"
instance (Show a, KnownSymbol name) => Show (Rec '[name ::: a]) where
show (WithField x EmptyRec) = "{" <> symbolVal (Proxy @name) <> " = " <> show x <> "}"
instance (Show a, Show (Rec (y:ts)), KnownSymbol name) => Show (Rec (name ::: a : y : ts)) where
show (WithField x next) = "{" <> symbolVal (Proxy @name) <> " = " <> show x <> ", " <> tail (show next)
x = EmptyRec
& WithField @"a" (1 :: Int)
& WithField @"b" "2"
y = x ^. #a
z = x & field' @"b" %~ ("-" <>)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment