blankhart.hs

{-# Language TypeOperators, FlexibleContexts, DeriveGeneric #-}
module Demo where

import Control.Lens
import GHC.Generics ( (:+:)(L1,R1), M1, K1, Generic, Rep)
import GHC.Generics.Lens (_M1, _K1, generic)

data A = A Int       deriving (Show, Generic)
data B = B Int       deriving (Show, Generic)
data C = CA A | CB B deriving (Show, Generic)

class    HasInt a   where int :: Lens' a Int
instance HasInt Int where int = id
instance HasInt A   where int = generic_int
instance HasInt B   where int = generic_int
instance HasInt C   where int = generic_int


------------------------------------------------------------------------
-- GHC.Generics derived instance machinery
------------------------------------------------------------------------

generic_int :: (Generic a, GHasInt (Rep a)) => Lens' a Int
generic_int = generic . g_int

class GHasInt f where g_int :: Lens' (f x) Int
instance GHasInt f => GHasInt (M1 i c f) where g_int = _M1 . g_int
instance HasInt  a => GHasInt (K1 i a)   where g_int = _K1 . int
instance (GHasInt f, GHasInt g) => GHasInt (f :+: g) where
  g_int f (L1 x) = L1 <$> g_int f x
  g_int f (R1 x) = R1 <$> g_int f x