Optics.TH

data Animal
  = Cat { animalAge  :: Int
        , animalName :: String
        }
  | Dog { animalAge    :: Int
        , animalAbsurd :: forall a b. a -> b
        }
makeFieldLabels ''Animal

instance
  (k ~ A_Lens, a ~ Int, b ~ Int
  ) => LabelOptic "age" k Animal Animal a b where
  labelOptic = lensVL $ \f s -> case s of
    Cat x1 x2 -> fmap (\y -> Cat y x2) (f x1)
    Dog x1 x2 -> fmap (\y -> Dog y x2) (f x1)

instance
  (k ~ An_AffineTraversal, a ~ String, b ~ String
  ) => LabelOptic "name" k Animal Animal a b where
  labelOptic = atraversalVL $ \point f s -> case s of
    Cat x1 x2 -> fmap (\y -> Cat x1 y) (f x2)
    Dog x1 x2 -> point (Dog x1 x2)

instance
  ( Dysfunctional "absurd" k Animal Animal a b
  , k ~ An_AffineFold, a ~ (x -> y), b ~ (x -> y)
  ) => LabelOptic "absurd" k Animal Animal a b where
  labelOptic = afolding $ \s -> case s of
    Cat _ _  -> Nothing
    Dog _ f  -> Just f

makeFieldOptics = makeFieldLabelsWith fieldLabelsRules

makeFieldLabelsFor [("_foo", "fooLens"), ("baz", "lbaz")] ''Foo
makeFieldLabelsFor [("_barX", "bar"), ("_barY", "bar")] ''Bar

declareLenses [d|
  data Dog = Dog { name :: String, age :: Int }
    deriving Show
  |]

data Dog = Dog String Int
  deriving Show
instance (k ~ A_Lens, ...) => LabelOptic "name" k Dog Dog ...
instance (k ~ A_Lens, ...) => LabelOptic "age" k Dog Dog ...

data Animal
  = Cat { _age  :: Int
        , _name :: String
        }
  | Dog { _age    :: Int
        , _absurd :: forall a b. a -> b
        }
makeLenses ''Animal

absurd :: forall a b. AffineFold Animal (a -> b)
absurd = afolding $ \s -> case s of
  Cat _ _ -> Nothing
  Dog _ x -> Just x

age :: Lens' Animal Int
age = lensVL $ \f s -> case s of
  Cat x1 x2 -> fmap (\y -> Cat y x2) (f x1)
  Dog x1 x2 -> fmap (\y -> Dog y x2) (f x1)

name :: AffineTraversal' Animal String
name = atraversalVL $ \point f s -> case s of
  Cat x1 x2 -> fmap (\y -> Cat x1 y) (f x2)
  Dog x1 x2 -> point (Dog x1 x2)

makeLenses = makeLensesWith lensRules

makeLensesFor [("_foo", "fooLens"), ("baz", "lbaz")] ''Foo
makeLensesFor [("_barX", "bar"), ("_barY", "bar")] ''Bar

declareLenses [d|
  data Foo = Foo { fooX, fooY :: Int }
    deriving Show
  |]

data Foo = Foo Int Int deriving Show
fooX, fooY :: Lens' Foo Int

data Foo = Foo { _fooX, _fooY :: Int }
makeClassy ''Foo

class HasFoo c where
  foo  :: Lens' c Foo
  fooX :: Lens' c Int
  fooY :: Lens' c Int
  fooX = foo % fooX
  fooY = foo % fooY

instance HasFoo Foo where
  foo  = lensVL id
  fooX = lensVL $ \f s -> case s of
    Foo x1 x2 -> fmap (\y -> Foo y x2) (f x1)
  fooY = lensVL $ \f s -> case s of
    Foo x1 x2 -> fmap (\y -> Foo x1 y) (f x2)

makeClassy = makeLensesWith classyRules

makeClassyFor "HasFoo" "foo" [("_foo", "fooLens"), ("bar", "lbar")] ''Foo

declareClassy [d|
  data Foo = Foo { fooX, fooY :: Int }
    deriving Show
  |]

data Foo = Foo Int Int deriving Show
class HasFoo t where
  foo :: Lens' t Foo
instance HasFoo Foo where foo = id
fooX, fooY :: HasFoo t => Lens' t Int

data Foo a = Foo { _fooX :: Int, _fooY :: a }
newtype Bar = Bar { _barX :: Char }
makeFields ''Foo
makeFields ''Bar

class HasX s a | s -> a where
  x :: Lens' s a

instance HasX (Foo a) Int where
  x = lensVL $ \f s -> case s of
    Foo x1 x2 -> fmap (\y -> Foo y x2) (f x1)

class HasY s a | s -> a where
  y :: Lens' s a

instance HasY (Foo a) a where
  y = lensVL $ \f s -> case s of
    Foo x1 x2 -> fmap (\y -> Foo x1 y) (f x2)

instance HasX Bar Char where
  x = lensVL $ \f s -> case s of
    Bar x1 -> fmap (\y -> Bar y) (f x1)

makeFields = makeLensesWith defaultFieldRules

data Foo a  = Foo { _x :: Int, _y :: a }
newtype Bar = Bar { _x :: Char }
makeFieldsNoPrefix ''Foo
makeFieldsNoPrefix ''Bar

class HasX s a | s -> a where
  x :: Lens' s a
class HasY s a | s -> a where
  y :: Lens' s a

instance HasX (Foo a) Int
instance HasY (Foo a) a where
instance HasX Bar Char where

makeFieldsNoPrefix = makeLensesWith classUnderscoreNoPrefixFields

 declareFields = declareLensesWith defaultFieldRules

data FooBarBaz a
  = Foo Int
  | Bar a
  | Baz Int Char
makePrisms ''FooBarBaz

_Foo :: Prism' (FooBarBaz a) Int
_Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b
_Baz :: Prism' (FooBarBaz a) (Int, Char)

declarePrisms [d|
  data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }
  |]

data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }
_Lit :: Prism' Exp Int
_Var :: Prism' Exp String
_Lambda :: Prism' Exp (String, Exp)

data FooBarBaz a
  = Foo Int
  | Bar a
  | Baz Int Char
makeClassyPrisms ''FooBarBaz

class AsFooBarBaz s a | s -> a where
  _FooBarBaz :: Prism' s (FooBarBaz a)
  _Foo :: Prism' s Int
  _Bar :: Prism' s a
  _Baz :: Prism' s (Int,Char)

  _Foo = _FooBarBaz % _Foo
  _Bar = _FooBarBaz % _Bar
  _Baz = _FooBarBaz % _Baz

instance AsFooBarBaz (FooBarBaz a) a