content: module Optics.TH
    (
    -- * Generation of field optics
    -- ** Labels
      makeFieldLabels
    , makeFieldLabelsNoPrefix
    , makeFieldLabelsFor
    , makeFieldLabelsWith
    , declareFieldLabels
    , declareFieldLabelsFor
    , declareFieldLabelsWith
    , fieldLabelsRules
    , fieldLabelsRulesFor
    -- ** Functions
    , makeLenses
    , makeLensesFor
    , makeLensesWith
    , declareLenses
    , declareLensesFor
    , declareLensesWith
    , lensRules
    , lensRulesFor
    -- ** Single class per data type
    -- $deprecatedClassy
    , makeClassy
    , makeClassy_
    , makeClassyFor
    , declareClassy
    , declareClassyFor
    , classyRules
    , classyRules_
    , classyRulesFor
    -- ** Multiple classes per data type
    -- $deprecatedFields
    , makeFields
    , makeFieldsNoPrefix
    , declareFields
    , defaultFieldRules
    -- * Generation of constructor optics
    -- ** Labels
    , makePrismLabels
    -- ** Functions
    , makePrisms
    , declarePrisms
    -- ** Single class per data type
    , makeClassyPrisms
    -- * Generation rules for field optics
    , LensRules
    , simpleLenses
    , generateSignatures
    , generateUpdateableOptics
    , generateLazyPatterns
    , createClass
    , lensField
    , lensClass
    -- * Common rules
    , noPrefixFieldLabels
    , abbreviatedFieldLabels
    , underscoreFields
    , camelCaseFields
    , classUnderscoreNoPrefixFields
    , abbreviatedFields
    -- * Field namers
    , FieldNamer
    , ClassyNamer
    , DefName(..)
    , noPrefixNamer
    , underscoreNoPrefixNamer
    , lookingupNamer
    , mappingNamer
    , underscoreNamer
    , camelCaseNamer
    , classUnderscoreNoPrefixNamer
    , abbreviatedNamer
    ) where
  
  import Control.Monad.Trans.Class
  import Control.Monad.Trans.State
  import Control.Monad.Trans.Writer
  import Data.Char (toLower, toUpper, isUpper)
  import Data.Maybe (maybeToList)
  import Data.Monoid
  import Data.Set (Set)
  import Language.Haskell.TH.Syntax hiding (lift)
  import Language.Haskell.TH
  import qualified Data.List as L
  import qualified Data.Set as Set
  
  import Optics.Core hiding (cons)
  import Optics.TH.Internal.Product
  import Optics.TH.Internal.Sum
  
  ----------------------------------------
  -- Labels
  
  -- | Build field optics as instances of the 'LabelOptic' class for use with
  -- overloaded labels.  See "Optics.Label" for how to use this pattern.
  --
  -- /e.g./
  --
  -- @
  -- data Animal
  --   = Cat { animalAge  :: Int
  --         , animalName :: String
  --         }
  --   | Dog { animalAge    :: Int
  --         , animalAbsurd :: forall a b. a -> b
  --         }
  -- makeFieldLabels ''Animal
  -- @
  --
  -- will create
  --
  -- @
  -- 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
  -- @
  --
  -- which can be used as @#age@, @#name@ and @#absurd@ with the
  -- @OverloadedLabels@ language extension.
  --
  -- /Note:/ if you wonder about the structure of instances, see
  -- "Optics.Label#structure".
  --
  -- @
  -- 'makeFieldOptics' = 'makeFieldLabelsWith' 'fieldLabelsRules'
  -- @
  makeFieldLabels :: Name -> DecsQ
  makeFieldLabels = makeFieldLabelsWith fieldLabelsRules
  
  -- | An alias for @makeFieldLabels noPrefixFieldLabels@.
  makeFieldLabelsNoPrefix :: Name -> DecsQ
  makeFieldLabelsNoPrefix = makeFieldLabelsWith noPrefixFieldLabels
  
  -- | Derive field optics as labels, specifying explicit pairings of @(fieldName,
  -- labelName)@.
  --
  -- If you map multiple fields to the same label and it is present in the same
  -- constructor, 'Traversal' (or 'Fold' for a read only version) will be
  -- generated.
  --
  -- /e.g./
  --
  -- @
  -- 'makeFieldLabelsFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo
  -- 'makeFieldLabelsFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar
  -- @
  makeFieldLabelsFor :: [(String, String)] -> Name -> DecsQ
  makeFieldLabelsFor fields = makeFieldLabelsWith (fieldLabelsRulesFor fields)
  
  -- | Make field optics as labels for all records in the given declaration
  -- quote. All record syntax in the input will be stripped off.
  --
  -- /e.g./
  --
  -- @
  -- declareLenses [d|
  --   data Dog = Dog { name :: String, age :: Int }
  --     deriving Show
  --   |]
  -- @
  --
  -- will create
  --
  -- @
  -- 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 ...
  -- @
  declareFieldLabels :: DecsQ -> DecsQ
  declareFieldLabels
    = declareFieldLabelsWith
    $ fieldLabelsRules
    & lensField .~ noPrefixNamer
  
  -- | Similar to 'makeFieldLabelsFor', but takes a declaration quote.
  declareFieldLabelsFor :: [(String, String)] -> DecsQ -> DecsQ
  declareFieldLabelsFor fields
    = declareFieldLabelsWith
    $ fieldLabelsRulesFor fields
    & lensField .~ noPrefixNamer
  
  -- Similar to 'makeFieldLabelsWith', but takes a declaration quote.
  declareFieldLabelsWith :: LensRules -> DecsQ -> DecsQ
  declareFieldLabelsWith rules = declareWith $ \dec -> do
    emit =<< liftDeclare (makeFieldLabelsForDec rules dec)
    return $ stripFields dec
  
  -- | Rules for generation of 'LabelOptic' instances for use with
  -- OverloadedLabels. Same as 'lensRules', but uses 'camelCaseNamer'.
  --
  -- /Note:/ if you don't want to prefix field names with the full name of the
  -- data type, you can use 'abbreviatedNamer' instead.
  fieldLabelsRules :: LensRules
  fieldLabelsRules = LensRules
    { _simpleLenses    = False
    , _generateSigs    = True
    , _generateClasses = False
    , _allowIsos       = True
    , _allowUpdates    = True
    , _lazyPatterns    = False
    , _classyLenses    = const Nothing
    , _fieldToDef      = camelCaseNamer
    }
  
  -- | Construct a 'LensRules' value for generating 'LabelOptic' instances using
  -- the given map from field names to definition names.
  fieldLabelsRulesFor
    :: [(String, String)] {- ^ [(Field name, Label name)] -}
    -> LensRules
  fieldLabelsRulesFor fields = fieldLabelsRules & lensField .~ lookingupNamer fields
  
  ----------------------------------------
  -- Lenses
  
  -- | Build field optics as top level functions with a sensible default
  -- configuration.
  --
  -- /e.g./
  --
  -- @
  -- data Animal
  --   = Cat { _age  :: 'Int'
  --         , _name :: 'String'
  --         }
  --   | Dog { _age    :: 'Int'
  --         , _absurd :: forall a b. a -> b
  --         }
  -- 'makeLenses' ''Animal
  -- @
  --
  -- will create
  --
  -- @
  -- 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'
  -- @
  makeLenses :: Name -> DecsQ
  makeLenses = makeFieldOptics lensRules
  
  -- | Derive field optics, specifying explicit pairings of @(fieldName,
  -- opticName)@.
  --
  -- If you map multiple fields to the same optic and it is present in the same
  -- constructor, 'Traversal' (or 'Fold' for a read only version) will be
  -- generated.
  --
  -- /e.g./
  --
  -- @
  -- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo
  -- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar
  -- @
  makeLensesFor :: [(String, String)] -> Name -> DecsQ
  makeLensesFor fields = makeFieldOptics (lensRulesFor fields)
  
  -- | Build field optics with a custom configuration.
  makeLensesWith :: LensRules -> Name -> DecsQ
  makeLensesWith = makeFieldOptics
  
  -- | Make field optics for all records in the given declaration quote. All
  -- record syntax in the input will be stripped off.
  --
  -- /e.g./
  --
  -- @
  -- declareLenses [d|
  --   data Foo = Foo { fooX, fooY :: 'Int' }
  --     deriving 'Show'
  --   |]
  -- @
  --
  -- will create
  --
  -- @
  -- data Foo = Foo 'Int' 'Int' deriving 'Show'
  -- fooX, fooY :: 'Lens'' Foo Int
  -- @
  declareLenses :: DecsQ -> DecsQ
  declareLenses
    = declareLensesWith
    $ lensRules
    & lensField .~ noPrefixNamer
  
  -- | Similar to 'makeLensesFor', but takes a declaration quote.
  declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
  declareLensesFor fields
    = declareLensesWith
    $ lensRulesFor fields
    & lensField .~ noPrefixNamer
  
  -- | 'declareLenses' with custom 'LensRules'.
  declareLensesWith :: LensRules -> DecsQ -> DecsQ
  declareLensesWith rules = declareWith $ \dec -> do
    emit =<< lift (makeFieldOpticsForDec' rules dec)
    return $ stripFields dec
  
  -- | Rules for making read-write field optics as top-level functions. It uses
  -- 'underscoreNoPrefixNamer'.
  lensRules :: LensRules
  lensRules = LensRules
    { _simpleLenses    = False
    , _generateSigs    = True
    , _generateClasses = False
    , _allowIsos       = True
    , _allowUpdates    = True
    , _lazyPatterns    = False
    , _classyLenses    = const Nothing
    , _fieldToDef      = underscoreNoPrefixNamer
    }
  
  -- | Construct a 'LensRules' value for generating top-level functions using the
  -- given map from field names to definition names.
  lensRulesFor
    :: [(String, String)] {- ^ [(Field name, Optic name)] -}
    -> LensRules
  lensRulesFor fields = lensRules & lensField .~ lookingupNamer fields
  
  ----------------------------------------
  -- Classy
  
  -- $deprecatedClassy
  --
  -- This method of optics generation should only be used when migrating an
  -- existing codebase from the @lens@ library to @optics@ as it:
  --
  -- - Doesn't support prefixless fields.
  --
  -- - Doesn't support type changing updates.
  --
  -- See "Optics.Label" for our recommended pattern.
  
  -- | Make lenses and traversals for a type, and create a class when the type has
  -- no arguments.
  --
  -- /e.g./
  --
  -- @
  -- data Foo = Foo { _fooX, _fooY :: 'Int' }
  -- 'makeClassy' ''Foo
  -- @
  --
  -- will create
  --
  -- @
  -- 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'
  -- @
  makeClassy :: Name -> DecsQ
  makeClassy = makeFieldOptics classyRules
  
  -- | Make lenses and traversals for a type, and create a class when the type has
  -- no arguments. Works the same as 'makeClassy' except that (a) it expects that
  -- record field names do not begin with an underscore, (b) all record fields are
  -- made into lenses, and (c) the resulting lens is prefixed with an underscore.
  makeClassy_ :: Name -> DecsQ
  makeClassy_ = makeFieldOptics classyRules_
  
  -- | Derive lenses and traversals, using a named wrapper class, and
  -- specifying explicit pairings of @(fieldName, traversalName)@.
  --
  -- Example usage:
  --
  -- @
  -- 'makeClassyFor' \"HasFoo\" \"foo\" [(\"_foo\", \"fooLens\"), (\"bar\", \"lbar\")] ''Foo
  -- @
  makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
  makeClassyFor clsName funName fields = makeFieldOptics $
    classyRulesFor (const (Just (clsName, funName))) fields
  
  -- | For each record in the declaration quote, make lenses and traversals for
  -- it, and create a class when the type has no arguments. All record syntax
  -- in the input will be stripped off.
  --
  -- /e.g./
  --
  -- @
  -- declareClassy [d|
  --   data Foo = Foo { fooX, fooY :: 'Int' }
  --     deriving 'Show'
  --   |]
  -- @
  --
  -- will create
  --
  -- @
  -- 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'
  -- @
  declareClassy :: DecsQ -> DecsQ
  declareClassy
    = declareLensesWith
    $ classyRules
    & lensField .~ noPrefixNamer
  
  -- | Similar to 'makeClassyFor', but takes a declaration quote.
  declareClassyFor ::
    [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ
  declareClassyFor classes fields
    = declareLensesWith
    $ classyRulesFor (`Prelude.lookup`classes) fields
    & lensField .~ noPrefixNamer
  
  -- | Rules for making lenses and traversals that precompose another 'Lens'.
  classyRules :: LensRules
  classyRules = LensRules
    { _simpleLenses    = True
    , _generateSigs    = True
    , _generateClasses = True
    , _allowIsos       = False -- generating Isos would hinder "subtyping"
    , _allowUpdates    = True
    , _lazyPatterns    = False
    , _classyLenses    = \n ->
          case nameBase n of
            x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs))
            []   -> Nothing
    , _fieldToDef      = underscoreNoPrefixNamer
    }
  
  -- | A 'LensRules' used by 'makeClassy_'.
  classyRules_ :: LensRules
  classyRules_
    = classyRules & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))]
  
  -- | Rules for making lenses and traversals that precompose another 'Lens' using
  -- a custom function for naming the class, main class method, and a mapping from
  -- field names to definition names.
  classyRulesFor
    :: (String -> Maybe (String, String)) {- ^ Type Name -> Maybe (Class Name, Method Name) -} ->
    [(String, String)] {- ^ [(Field Name, Method Name)] -} ->
    LensRules
  classyRulesFor classFun fields = classyRules
    & lensClass .~ (over (mapped % each) mkName . classFun . nameBase)
    & lensField .~ lookingupNamer fields
  
  ----------------------------------------
  -- Fields
  
  -- $deprecatedFields
  --
  -- This method of optics generation should only be used when migrating an
  -- existing codebase from the @lens@ library to @optics@ as it:
  --
  -- - Doesn't support type changing updates.
  --
  -- - Introduces tight coupling between types in your application as either all
  --   types need to be put in a single module (for @HasX@ class generation to
  --   work properly) or there needs to be a single, written by hand module with
  --   all the @HasX@ classes the application will use. Both approaches don't
  --   scale.
  --
  -- - Can't be leveraged by libraries because of the above problem lifted to the
  --   library level: there would have to exist a library with all possible @HasX@
  --   classes written by hand that is imported by all the other
  --   libraries. Otherwise for a given @field@ independent libraries would
  --   provide multiple @HasField@ classes incompatible with each other.
  --
  -- See "Optics.Label" for our recommended pattern.
  
  -- | Generate overloaded field accessors.
  --
  -- /e.g/
  --
  -- @
  -- data Foo a = Foo { _fooX :: 'Int', _fooY :: a }
  -- newtype Bar = Bar { _barX :: 'Char' }
  -- makeFields ''Foo
  -- makeFields ''Bar
  -- @
  --
  -- will create
  --
  -- @
  -- 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)
  -- @
  --
  -- For details, see 'camelCaseFields'.
  --
  -- @
  -- makeFields = 'makeLensesWith' 'defaultFieldRules'
  -- @
  makeFields :: Name -> DecsQ
  makeFields = makeFieldOptics camelCaseFields
  
  -- | Generate overloaded field accessors based on field names which
  -- are only prefixed with an underscore (e.g. '_name'), not
  -- additionally with the type name (e.g. '_fooName').
  --
  -- This might be the desired behaviour in case the
  -- @DuplicateRecordFields@ language extension is used in order to get
  -- rid of the necessity to prefix each field name with the type name.
  --
  -- As an example:
  --
  -- @
  -- data Foo a  = Foo { _x :: 'Int', _y :: a }
  -- newtype Bar = Bar { _x :: 'Char' }
  -- makeFieldsNoPrefix ''Foo
  -- makeFieldsNoPrefix ''Bar
  -- @
  --
  -- will create classes
  --
  -- @
  -- class HasX s a | s -> a where
  --   x :: Lens' s a
  -- class HasY s a | s -> a where
  --   y :: Lens' s a
  -- @
  --
  -- together with instances
  --
  -- @
  -- instance HasX (Foo a) Int
  -- instance HasY (Foo a) a where
  -- instance HasX Bar Char where
  -- @
  --
  -- For details, see 'classUnderscoreNoPrefixFields'.
  --
  -- @
  -- makeFieldsNoPrefix = 'makeLensesWith' 'classUnderscoreNoPrefixFields'
  -- @
  makeFieldsNoPrefix :: Name -> DecsQ
  makeFieldsNoPrefix = makeFieldOptics classUnderscoreNoPrefixFields
  
  -- | @ declareFields = 'declareLensesWith' 'defaultFieldRules' @
  declareFields :: DecsQ -> DecsQ
  declareFields = declareLensesWith defaultFieldRules
  
  defaultFieldRules :: LensRules
  defaultFieldRules = LensRules
    { _simpleLenses    = True
    , _generateSigs    = True
    , _generateClasses = True  -- classes will still be skipped if they already exist
    , _allowIsos       = False -- generating Isos would hinder field class reuse
    , _allowUpdates    = True
    , _lazyPatterns    = False
    , _classyLenses    = const Nothing
    , _fieldToDef      = camelCaseNamer
    }
  
  ----------------------------------------
  -- Prisms
  
  -- | Generate a 'Control.Lens.Type.Prism' for each constructor of each data type.
  --
  -- /e.g./
  --
  -- @
  -- declarePrisms [d|
  --   data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }
  --   |]
  -- @
  --
  -- will create
  --
  -- @
  -- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }
  -- _Lit :: 'Prism'' Exp Int
  -- _Var :: 'Prism'' Exp String
  -- _Lambda :: 'Prism'' Exp (String, Exp)
  -- @
  declarePrisms :: DecsQ -> DecsQ
  declarePrisms = declareWith $ \dec -> do
    emit =<< liftDeclare (makeDecPrisms True dec)
    return dec
  
  ----------------------------------------
  -- Customization of rules
  
  -- | Generate "simple" optics even when type-changing optics are possible.
  -- (e.g. 'Lens'' instead of 'Lens')
  simpleLenses :: Lens' LensRules Bool
  simpleLenses = lensVL $ \f r ->
    fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses r))
  
  -- | Indicate whether or not to supply the signatures for the generated lenses.
  --
  -- Disabling this can be useful if you want to provide a more restricted type
  -- signature or if you want to supply hand-written haddocks.
  generateSignatures :: Lens' LensRules Bool
  generateSignatures = lensVL $ \f r ->
    fmap (\x -> r { _generateSigs = x}) (f (_generateSigs r))
  
  -- | Generate "updateable" optics when 'True'. When 'False', (affine) folds will
  -- be generated instead of (affine) traversals and getters will be generated
  -- instead of lenses. This mode is intended to be used for types with invariants
  -- which must be maintained by "smart" constructors.
  generateUpdateableOptics :: Lens' LensRules Bool
  generateUpdateableOptics = lensVL $ \f r ->
    fmap (\x -> r { _allowUpdates = x}) (f (_allowUpdates r))
  
  -- | Generate optics using lazy pattern matches. This can
  -- allow fields of an undefined value to be initialized with lenses:
  --
  -- @
  -- data Foo = Foo {_x :: Int, _y :: Bool}
  --   deriving Show
  --
  -- 'makeLensesWith' ('lensRules' & 'generateLazyPatterns' .~ True) ''Foo
  -- @
  --
  -- @
  -- > undefined & x .~ 8 & y .~ True
  -- Foo {_x = 8, _y = True}
  -- @
  --
  -- The downside of this flag is that it can lead to space-leaks and
  -- code-size/compile-time increases when generated for large records. By default
  -- this flag is turned off, and strict optics are generated.
  --
  -- When using lazy optics the strict optic can be recovered by composing with
  -- 'equality'':
  --
  -- @
  -- strictOptic = equality' % lazyOptic
  -- @
  generateLazyPatterns :: Lens' LensRules Bool
  generateLazyPatterns = lensVL $ \f r ->
    fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r))
  
  -- | Create the class if the constructor if generated lenses would be
  -- type-preserving and the 'lensClass' rule matches.
  createClass :: Lens' LensRules Bool
  createClass = lensVL $ \f r ->
    fmap (\x -> r { _generateClasses = x}) (f (_generateClasses r))
  
  -- | 'Lens'' to access the convention for naming fields in our 'LensRules'.
  lensField :: Lens' LensRules FieldNamer
  lensField = lensVL $ \f r ->
    fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r))
  
  -- | 'Lens'' to access the option for naming "classy" lenses.
  lensClass :: Lens' LensRules ClassyNamer
  lensClass = lensVL $ \f r ->
    fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r))
  
  ----------------------------------------
  -- Common sets of rules
  
  -- | Field rules for fields without any prefix. Useful for generation of field
  -- labels when paired with @DuplicateRecordFields@ language extension so that no
  -- prefixes for field names are necessary.
  --
  -- @since 0.2
  noPrefixFieldLabels :: LensRules
  noPrefixFieldLabels = fieldLabelsRules { _fieldToDef = noPrefixNamer }
  
  abbreviatedFieldLabels :: LensRules
  abbreviatedFieldLabels = fieldLabelsRules { _fieldToDef = abbreviatedNamer }
  
  -- | Field rules for fields in the form @ _prefix_fieldname @
  underscoreFields :: LensRules
  underscoreFields = defaultFieldRules & lensField .~ underscoreNamer
  
  -- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @
  --
  -- If you want all fields to be lensed, then there is no reason to use an @_@
  -- before the prefix.  If any of the record fields leads with an @_@ then it is
  -- assume a field without an @_@ should not have a lens created.
  --
  -- __Note__: The @prefix@ must be the same as the typename (with the first
  -- letter lowercased). This is a change from lens versions before lens 4.5. If
  -- you want the old behaviour, use 'makeLensesWith' 'abbreviatedFields'
  camelCaseFields :: LensRules
  camelCaseFields = defaultFieldRules
  
  -- | Field rules for fields in the form @ _fieldname @ (the leading
  -- underscore is mandatory).
  --
  -- __Note__: The primary difference to 'camelCaseFields' is that for
  -- @classUnderscoreNoPrefixFields@ the field names are not expected to
  -- be prefixed with the type name. This might be the desired behaviour
  -- when the @DuplicateRecordFields@ extension is enabled.
  classUnderscoreNoPrefixFields :: LensRules
  classUnderscoreNoPrefixFields =
    defaultFieldRules & lensField .~ classUnderscoreNoPrefixNamer
  
  -- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @
  -- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.
  -- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.
  --
  -- Note that @prefix@ may be any string of characters that are not uppercase
  -- letters. (In particular, it may be arbitrary string of lowercase letters
  -- and numbers) This is the behavior that 'defaultFieldRules' had in lens
  -- 4.4 and earlier.
  abbreviatedFields :: LensRules
  abbreviatedFields = defaultFieldRules { _fieldToDef = abbreviatedNamer }
  
  ----------------------------------------
  -- Namers
  
  -- | A 'FieldNamer' that leaves the field name as-is. Useful for generation of
  -- field labels when paired with @DuplicateRecordFields@ language extension so
  -- that no prefixes for field names are necessary.
  --
  -- @since 0.2
  noPrefixNamer :: FieldNamer
  noPrefixNamer _ _ n = [TopName n]
  
  -- | A 'FieldNamer' that strips the _ off of the field name, lowercases the
  -- name, and skips the field if it doesn't start with an '_'.
  underscoreNoPrefixNamer :: FieldNamer
  underscoreNoPrefixNamer _ _ n =
    case nameBase n of
      '_':x:xs -> [TopName (mkName (toLower x:xs))]
      _        -> []
  
  
  -- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@.
  lookingupNamer :: [(String,String)] -> FieldNamer
  lookingupNamer kvs _ _ field =
    [ TopName (mkName v) | (k,v) <- kvs, k == nameBase field]
  
  -- | Create a 'FieldNamer' from a mapping function. If the function returns
  -- @[]@, it creates no lens for the field.
  mappingNamer :: (String -> [String]) -- ^ A function that maps a @fieldName@ to
                                       -- @lensName@s.
               -> FieldNamer
  mappingNamer mapper _ _ = fmap (TopName . mkName) . mapper . nameBase
  
  -- | A 'FieldNamer' for 'underscoreFields'.
  underscoreNamer :: FieldNamer
  underscoreNamer _ _ field = maybeToList $ do
    _      <- prefix field'
    method <- niceLens
    cls    <- classNaming
    return (MethodName (mkName cls) (mkName method))
    where
      field' = nameBase field
      prefix ('_':xs) | '_' `L.elem` xs = Just (takeWhile (/= '_') xs)
      prefix _                          = Nothing
      niceLens    = prefix field' <&> \n -> drop (length n + 2) field'
      classNaming = niceLens <&> ("Has_" ++)
  
  -- | A 'FieldNamer' for 'camelCaseFields'.
  camelCaseNamer :: FieldNamer
  camelCaseNamer tyName fields field = maybeToList $ do
  
    fieldPart <- L.stripPrefix expectedPrefix (nameBase field)
    method    <- computeMethod fieldPart
    let cls = "Has" ++ fieldPart
    return (MethodName (mkName cls) (mkName method))
  
    where
    expectedPrefix = optUnderscore ++ over _head toLower (nameBase tyName)
  
    optUnderscore  = ['_' | any (L.isPrefixOf "_" . nameBase) fields ]
  
    computeMethod (x:xs) | isUpper x = Just (toLower x : xs)
    computeMethod _                  = Nothing
  
  -- | A 'FieldNamer' for 'classUnderscoreNoPrefixFields'.
  classUnderscoreNoPrefixNamer :: FieldNamer
  classUnderscoreNoPrefixNamer _ _ field = maybeToList $ do
    fieldUnprefixed <- L.stripPrefix "_" (nameBase field)
    let className  = "Has" ++ over _head toUpper fieldUnprefixed
        methodName = fieldUnprefixed
    return (MethodName (mkName className) (mkName methodName))
  
  -- | A 'FieldNamer' for 'abbreviatedFields'.
  abbreviatedNamer :: FieldNamer
  abbreviatedNamer _ fields field = maybeToList $ do
  
    fieldPart <- stripMaxLc (nameBase field)
    method    <- computeMethod fieldPart
    let cls = "Has" ++ fieldPart
    return (MethodName (mkName cls) (mkName method))
  
    where
    stripMaxLc f = do x <- L.stripPrefix optUnderscore f
                      case break isUpper x of
                        (p,s) | L.null p || L.null s -> Nothing
                              | otherwise            -> Just s
    optUnderscore  = ['_' | any (L.isPrefixOf "_" . nameBase) fields ]
  
    computeMethod (x:xs) | isUpper x = Just (toLower x : xs)
    computeMethod _                  = Nothing
  
  ----------------------------------------
  -- Internal TH Implementation
  
  -- Declaration quote stuff
  
  declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
  declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<)
  
  -- | Monad for emitting top-level declarations as a side effect. We also track
  -- the set of field class 'Name's that have been created and consult them to
  -- avoid creating duplicate classes.
  
  -- See #463 for more information.
  type Declare = WriterT (Endo [Dec]) (StateT (Set Name) Q)
  
  liftDeclare :: Q a -> Declare a
  liftDeclare = lift . lift
  
  runDeclare :: Declare [Dec] -> DecsQ
  runDeclare dec = do
    (out, endo) <- evalStateT (runWriterT dec) Set.empty
    return $ out ++ appEndo endo []
  
  emit :: [Dec] -> Declare ()
  emit decs = tell $ Endo (decs++)
  
  -- | Traverse each data, newtype, data instance or newtype instance
  -- declaration.
  traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]
  traverseDataAndNewtype f decs = traverse go decs
    where
      go dec = case dec of
        DataD{} -> f dec
        NewtypeD{} -> f dec
        DataInstD{} -> f dec
        NewtypeInstD{} -> f dec
  
        -- Recurse into instance declarations because they main contain
        -- associated data family instances.
        InstanceD moverlap ctx inst body -> InstanceD moverlap ctx inst <$> traverse go body
        _ -> pure dec
  
  stripFields :: Dec -> Dec
  stripFields dec = case dec of
    DataD ctx tyName tyArgs kind cons derivings ->
      DataD ctx tyName tyArgs kind (map deRecord cons) derivings
    NewtypeD ctx tyName tyArgs kind con derivings ->
      NewtypeD ctx tyName tyArgs kind (deRecord con) derivings
    DataInstD ctx tyName tyArgs kind cons derivings ->
      DataInstD ctx tyName tyArgs kind (map deRecord cons) derivings
    NewtypeInstD ctx tyName tyArgs kind con derivings ->
      NewtypeInstD ctx tyName tyArgs kind (deRecord con) derivings
    _ -> dec
  
  deRecord :: Con -> Con
  deRecord con@NormalC{} = con
  deRecord con@InfixC{} = con
  deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con
  deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields)
  deRecord con@GadtC{} = con
  deRecord (RecGadtC ns fields retTy) = GadtC ns (map dropFieldName fields) retTy
  
  dropFieldName :: VarBangType -> BangType
  dropFieldName (_, str, typ) = (str, typ)
  