generic-lens-anon-records.hs

{-# 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" %~ ("-" <>)