subfield

Main.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

import Control.Lens (Lens', (&), (*~), (^.))
import Data.Generics.Labels ()
import Data.Generics.Product.Fields (HasField' (field'))
import Data.Kind (Constraint, Type)
import GHC.Generics (C1, D1, Generic (Rep, from, to), K1 (K1), M1 (M1), Rec0, S1, type (:+:) (L1, R1))
import GHC.TypeLits (Symbol)

type GSubField :: Symbol -> (Type -> Type) -> Type -> Constraint
class GSubField field rep a | field rep -> a where
  gsubField' :: Lens' (rep x) a

instance GSubField field cons a => GSubField field (D1 meta cons) a where
  gsubField' next (M1 a) = M1 <$> gsubField' @field next a

instance (GSubField field c1 a, GSubField field c2 a) => GSubField field (c1 :+: c2) a where
  gsubField' next = \case
    L1 a -> L1 <$> gsubField' @field next a
    R1 a -> R1 <$> gsubField' @field next a

instance GSubField field sels a => GSubField field (C1 meta sels) a where
  gsubField' next (M1 x) = M1 <$> gsubField' @field next x

instance HasField' field s a => GSubField field (S1 meta (Rec0 s)) a where
  gsubField' next (M1 (K1 x)) = M1 . K1 <$> field' @field next x

subField' :: forall field s a. (Generic s, GSubField field (Rep s) a) => Lens' s a
subField' next x = to <$> gsubField' @field next (from x)

-- Example

data A = A {a :: Int, b :: String} deriving stock (Generic, Show)

data B = B {a :: Int, c :: Int} deriving stock (Generic, Show)

data C = MkA A | MkB B deriving stock (Generic, Show)

instance {-# OVERLAPPING #-} HasField' "a" C Int where
  field' = subField' @"a"

main = do
  print (MkA (A 1 "2") ^. #a)
  print (MkB (B 1 2) ^. #a)
  print (MkA (A 1 "2") & #a *~ 10 :: C)
  print (MkB (B 1 2) & #a *~ 10 :: C)

package.yaml

name: hspg

dependencies:
  - base
  - lens
  - generic-lens

executables:
  hspg:
    main: Main.hs