Build yourself a generic lens!

GenericLens.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module GenericLens where

import Data.Kind (Type)
import GHC.Generics
import GHC.TypeLits
import Data.Functor.Const

type Lens s t a b
  = forall f. Functor f => (a -> f b) -> (s -> f t)

type Lens' s a
  = Lens s s a a

view :: Lens s t a b -> s -> a
view l = getConst . l Const

---

data Person
  = Person
      { name :: String
      , age  :: Int
      }
  deriving Generic

getName :: Lens' Person String
getName = typed

getAge :: Lens' Person Int
getAge = typed

-- getLikesDogs :: Lens' Person Bool
-- getLikesDogs = typed

---

class HasType a s where
  typed :: Lens' s a

class GHasType a (s :: Type -> Type) where
  gtyped :: Lens' (s p) a

type family (x :: Bool) || (y :: Bool) :: Bool where
  'True || y = 'True
  x     || y = y

type family Found a (s :: Type -> Type) :: Bool where
  Found a (S1 _ (Rec0 a)) = 'True
  Found a (S1 _ (Rec0 _)) = 'False
  Found a (left :*: right) = Found a left || Found a right

class GHasTypeBranch (flag :: Bool) a (s :: Type -> Type) where
  gbranch :: Lens' (s p) a

instance GHasType a left
    => GHasTypeBranch 'True a (left :*: right) where
  gbranch = glens . gtyped
    where
      glens f (left :*: right) = (\left -> left :*: right) <$> f left

instance GHasType a right
    => GHasTypeBranch 'False a (left :*: right) where
  gbranch = glens . gtyped
    where
      glens f (left :*: right) = (\right -> left :*: right) <$> f right

instance (flag ~ Found a left, GHasTypeBranch flag a (left :*: right))
    => GHasType a (left :*: right) where
  gtyped = gbranch @flag

instance GHasType a (Rec0 a) where
  gtyped f = fmap K1 . f . unK1

instance {-# OVERLAPPABLE #-} TypeError (
      'Text "There's no " ':<>: 'ShowType b ':<>: 'Text " in here, Jim!"
    )
    => GHasType b (Rec0 a) where
  gtyped = undefined

instance GHasType a s => GHasType a (M1 sort meta s) where
  gtyped = glens . gtyped
    where
      glens :: Lens' ((M1 sort meta s) p) (s p)
      glens f = fmap M1 . f . unM1

instance (Generic s, GHasType a (Rep s))
    => HasType a s where
  typed = glens . gtyped
    where
      glens f = fmap to . f . from

instance {-# OVERLAPPABLE #-} HasType a a where
  typed = id

-- 1. Add the original type to the custom type error.
-- 2. Require that `a` is unique in `s`.
-- 3. Allow sum types if `a` is present in all constructors.