    {-# LANGUAGE CPP #-}
    {-# LANGUAGE PatternGuards #-}
    #ifdef TRUSTWORTHY
    # if MIN_VERSION_template_haskell(2,12,0)
    {-# LANGUAGE Safe #-}
    # else
    {-# LANGUAGE Trustworthy #-}
    # endif
    #endif

    #include "lens-common.h"

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Lens.TH
    -- Copyright   :  (C) 2012-16 Edward Kmett, 2012-13 Michael Sloan
    -- License     :  BSD-style (see the file LICENSE)
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -----------------------------------------------------------------------------
    module Control.Lens.TH
      (
      -- * Constructing Lenses Automatically
      -- ** Lenses for data fields
        makeLenses, makeLensesFor
      , makeClassy, makeClassyFor, makeClassy_
      , makeFields
      , makeFieldsNoPrefix
      -- ** Prisms
      , makePrisms
      , makeClassyPrisms
      -- ** Wrapped
      , makeWrapped
      -- * Constructing Lenses Given a Declaration Quote
      -- ** Lenses for data fields
      , declareLenses, declareLensesFor
      , declareClassy, declareClassyFor
      , declareFields
      -- ** Prisms
      , declarePrisms
      -- ** Wrapped
      , declareWrapped
      -- * Configuring Lenses
      -- ** Running LensRules
      , makeLensesWith
      , declareLensesWith
      -- ** LensRules type
      , LensRules
      -- ** Predefined LensRules
      , lensRules
      , lensRulesFor
      , classyRules
      , classyRules_
      , defaultFieldRules
      , camelCaseFields
      , classUnderscoreNoPrefixFields
      , underscoreFields
      , abbreviatedFields
      -- ** LensRules configuration accessors
      , lensField
      , FieldNamer
      , DefName(..)
      , lensClass
      , ClassyNamer
      , simpleLenses
      , createClass
      , generateSignatures
      , generateUpdateableOptics
      , generateLazyPatterns
      , generateRecordSyntax
      -- ** FieldNamers
      , underscoreNoPrefixNamer
      , lookingupNamer
      , mappingNamer
      , camelCaseNamer
      , classUnderscoreNoPrefixNamer
      , underscoreNamer
      , abbreviatedNamer
      ) where

    import Prelude ()

    import Control.Monad.Trans.Class
    import Control.Monad.Trans.State
    import Control.Monad.Trans.Writer
    import Control.Lens.Fold
    import Control.Lens.Getter
    import Control.Lens.Lens
    import Control.Lens.Setter
    import Control.Lens.Traversal
    import Control.Lens.Internal.Prelude as Prelude
    import Control.Lens.Internal.TH
    import Control.Lens.Internal.FieldTH
    import Control.Lens.Internal.PrismTH
    import Control.Lens.Wrapped () -- haddocks
    import Control.Lens.Type () -- haddocks
    import Data.Char (toLower, toUpper, isUpper)
    import Data.Foldable hiding (concat, any)
    import qualified Data.List as List
    import qualified Data.Map as Map
    import Data.Map (Map)
    import Data.Maybe (maybeToList)
    import qualified Data.Set as Set
    import Data.Set (Set)
    import Data.Traversable hiding (mapM)
    import Language.Haskell.TH.Datatype
    import Language.Haskell.TH.Lens
    import Language.Haskell.TH.Lib
    import Language.Haskell.TH.Syntax hiding (lift)

    -- | Generate "simple" optics even when type-changing optics are possible.
    -- (e.g. 'Lens'' instead of 'Lens')
    simpleLenses :: Lens' LensRules Bool
    simpleLenses :: Lens' LensRules Bool
    simpleLenses Bool -> f Bool
    f LensRules
    r = (Bool -> LensRules) -> f Bool -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\Bool
    x -> LensRules
    r { _simpleLenses :: Bool
    _simpleLenses = Bool
    x}) (Bool -> f Bool
    f (LensRules -> Bool
    _simpleLenses LensRules
    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 :: Lens' LensRules Bool
    generateSignatures Bool -> f Bool
    f LensRules
    r =
      (Bool -> LensRules) -> f Bool -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\Bool
    x -> LensRules
    r { _generateSigs :: Bool
    _generateSigs = Bool
    x}) (Bool -> f Bool
    f (LensRules -> Bool
    _generateSigs LensRules
    r))

    -- | Generate "updateable" optics when 'True'. When 'False', 'Fold's will be
    -- generated instead of 'Traversal's and 'Getter's will be generated instead
    -- of 'Lens'es. This mode is intended to be used for types with invariants
    -- which must be maintained by "smart" constructors.
    generateUpdateableOptics :: Lens' LensRules Bool
    generateUpdateableOptics :: Lens' LensRules Bool
    generateUpdateableOptics Bool -> f Bool
    f LensRules
    r =
      (Bool -> LensRules) -> f Bool -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\Bool
    x -> LensRules
    r { _allowUpdates :: Bool
    _allowUpdates = Bool
    x}) (Bool -> f Bool
    f (LensRules -> Bool
    _allowUpdates LensRules
    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 '$!':
    --
    -- @
    -- strictOptic = ($!) . lazyOptic
    -- @
    generateLazyPatterns :: Lens' LensRules Bool
    generateLazyPatterns :: Lens' LensRules Bool
    generateLazyPatterns Bool -> f Bool
    f LensRules
    r =
      (Bool -> LensRules) -> f Bool -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\Bool
    x -> LensRules
    r { _lazyPatterns :: Bool
    _lazyPatterns = Bool
    x}) (Bool -> f Bool
    f (LensRules -> Bool
    _lazyPatterns LensRules
    r))

    generateRecordSyntax :: Lens' LensRules Bool
    generateRecordSyntax :: Lens' LensRules Bool
    generateRecordSyntax Bool -> f Bool
    f LensRules
    r =
      (Bool -> LensRules) -> f Bool -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\Bool
    x -> LensRules
    r {_recordSyntax :: Bool
    _recordSyntax = Bool
    x}) (Bool -> f Bool
    f (LensRules -> Bool
    _recordSyntax LensRules
    r))

    -- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the
    -- 'lensClass' rule matches.
    createClass :: Lens' LensRules Bool
    createClass :: Lens' LensRules Bool
    createClass Bool -> f Bool
    f LensRules
    r =
      (Bool -> LensRules) -> f Bool -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\Bool
    x -> LensRules
    r { _generateClasses :: Bool
    _generateClasses = Bool
    x}) (Bool -> f Bool
    f (LensRules -> Bool
    _generateClasses LensRules
    r))

    -- | 'Lens'' to access the convention for naming fields in our 'LensRules'.
    lensField :: Lens' LensRules FieldNamer
    lensField :: Lens' LensRules FieldNamer
    lensField FieldNamer -> f FieldNamer
    f LensRules
    r = (FieldNamer -> LensRules) -> f FieldNamer -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\FieldNamer
    x -> LensRules
    r { _fieldToDef :: FieldNamer
    _fieldToDef = FieldNamer
    x}) (FieldNamer -> f FieldNamer
    f (LensRules -> FieldNamer
    _fieldToDef LensRules
    r))

    -- | 'Lens'' to access the option for naming "classy" lenses.
    lensClass :: Lens' LensRules ClassyNamer
    lensClass :: Lens' LensRules ClassyNamer
    lensClass ClassyNamer -> f ClassyNamer
    f LensRules
    r = (ClassyNamer -> LensRules) -> f ClassyNamer -> f LensRules
    forall a b. (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\ClassyNamer
    x -> LensRules
    r { _classyLenses :: ClassyNamer
    _classyLenses = ClassyNamer
    x }) (ClassyNamer -> f ClassyNamer
    f (LensRules -> ClassyNamer
    _classyLenses LensRules
    r))

    -- | Rules for making fairly simple partial lenses, ignoring the special cases
    -- for isomorphisms and traversals, and not making any classes.
    -- It uses 'underscoreNoPrefixNamer'.
    lensRules :: LensRules
    lensRules :: LensRules
    lensRules = LensRules
      { _simpleLenses :: Bool
    _simpleLenses    = Bool
    False
      , _generateSigs :: Bool
    _generateSigs    = Bool
    True
      , _generateClasses :: Bool
    _generateClasses = Bool
    False
      , _allowIsos :: Bool
    _allowIsos       = Bool
    True
      , _allowUpdates :: Bool
    _allowUpdates    = Bool
    True
      , _lazyPatterns :: Bool
    _lazyPatterns    = Bool
    False
      , _recordSyntax :: Bool
    _recordSyntax    = Bool
    False
      , _classyLenses :: ClassyNamer
    _classyLenses    = Maybe (Name, Name) -> ClassyNamer
    forall a b. a -> b -> a
    const Maybe (Name, Name)
    forall a. Maybe a
    Nothing
      , _fieldToDef :: FieldNamer
    _fieldToDef      = FieldNamer
    underscoreNoPrefixNamer
      }

    -- | 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 :: FieldNamer
    underscoreNoPrefixNamer Name
    _ [Name]
    _ Name
    n =
      case Name -> String
    nameBase Name
    n of
        Char
    '_':Char
    x:String
    xs -> [Name -> DefName
    TopName (String -> Name
    mkName (Char -> Char
    toLower Char
    xChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    xs))]
        String
    _        -> []

    -- | Construct a 'LensRules' value for generating top-level definitions
    -- using the given map from field names to definition names.
    lensRulesFor ::
      [(String, String)] {- ^ [(Field Name, Definition Name)] -} ->
      LensRules
    lensRulesFor :: [(String, String)] -> LensRules
    lensRulesFor [(String, String)]
    fields = LensRules
    lensRules LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ [(String, String)] -> FieldNamer
    lookingupNamer [(String, String)]
    fields

    -- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@.
    lookingupNamer :: [(String,String)] -> FieldNamer
    lookingupNamer :: [(String, String)] -> FieldNamer
    lookingupNamer [(String, String)]
    kvs Name
    _ [Name]
    _ Name
    field =
      [ Name -> DefName
    TopName (String -> Name
    mkName String
    v) | (String
    k,String
    v) <- [(String, String)]
    kvs, String
    k String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name -> String
    nameBase Name
    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 :: (String -> [String]) -> FieldNamer
    mappingNamer String -> [String]
    mapper Name
    _ [Name]
    _ = (String -> DefName) -> [String] -> [DefName]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Name -> DefName
    TopName (Name -> DefName) -> (String -> Name) -> String -> DefName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Name
    mkName) ([String] -> [DefName]) -> (Name -> [String]) -> Name -> [DefName]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    mapper (String -> [String]) -> (Name -> String) -> Name -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase

    -- | Rules for making lenses and traversals that precompose another 'Lens'.
    classyRules :: LensRules
    classyRules :: LensRules
    classyRules = LensRules
      { _simpleLenses :: Bool
    _simpleLenses    = Bool
    True
      , _generateSigs :: Bool
    _generateSigs    = Bool
    True
      , _generateClasses :: Bool
    _generateClasses = Bool
    True
      , _allowIsos :: Bool
    _allowIsos       = Bool
    False -- generating Isos would hinder "subtyping"
      , _allowUpdates :: Bool
    _allowUpdates    = Bool
    True
      , _lazyPatterns :: Bool
    _lazyPatterns    = Bool
    False
      , _recordSyntax :: Bool
    _recordSyntax    = Bool
    False
      , _classyLenses :: ClassyNamer
    _classyLenses    = \Name
    n ->
            case Name -> String
    nameBase Name
    n of
              Char
    x:String
    xs -> (Name, Name) -> Maybe (Name, Name)
    forall a. a -> Maybe a
    Just (String -> Name
    mkName (String
    "Has" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Char
    xChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    xs), String -> Name
    mkName (Char -> Char
    toLower Char
    xChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    xs))
              []   -> Maybe (Name, Name)
    forall a. Maybe a
    Nothing
      , _fieldToDef :: FieldNamer
    _fieldToDef      = FieldNamer
    underscoreNoPrefixNamer
      }

    -- | 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 :: (String -> Maybe (String, String))
    -> [(String, String)] -> LensRules
    classyRulesFor String -> Maybe (String, String)
    classFun [(String, String)]
    fields = LensRules
    classyRules
      LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (ClassyNamer -> Identity ClassyNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules ClassyNamer
    lensClass ((ClassyNamer -> Identity ClassyNamer)
     -> LensRules -> Identity LensRules)
    -> ClassyNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ (ASetter (Maybe (String, String)) (Maybe (Name, Name)) String Name
    -> (String -> Name) -> Maybe (String, String) -> Maybe (Name, Name)
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over (((String, String) -> Identity (Name, Name))
    -> Maybe (String, String) -> Identity (Maybe (Name, Name))
    Setter
      (Maybe (String, String))
      (Maybe (Name, Name))
      (String, String)
      (Name, Name)
    forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
    mapped (((String, String) -> Identity (Name, Name))
     -> Maybe (String, String) -> Identity (Maybe (Name, Name)))
    -> ((String -> Identity Name)
        -> (String, String) -> Identity (Name, Name))
    -> ASetter
         (Maybe (String, String)) (Maybe (Name, Name)) String Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Identity Name)
    -> (String, String) -> Identity (Name, Name)
    Traversal (String, String) (Name, Name) String Name
    forall (r :: * -> * -> *) a b.
    Bitraversable r =>
    Traversal (r a a) (r b b) a b
    both) String -> Name
    mkName (Maybe (String, String) -> Maybe (Name, Name))
    -> (Name -> Maybe (String, String)) -> ClassyNamer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Maybe (String, String)
    classFun (String -> Maybe (String, String))
    -> (Name -> String) -> Name -> Maybe (String, String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase)
      LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ [(String, String)] -> FieldNamer
    lookingupNamer [(String, String)]
    fields

    -- | A 'LensRules' used by 'makeClassy_'.
    classyRules_ :: LensRules
    classyRules_ :: LensRules
    classyRules_
      = LensRules
    classyRules LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ \Name
    _ [Name]
    _ Name
    n -> [Name -> DefName
    TopName (String -> Name
    mkName (Char
    '_'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Name -> String
    nameBase Name
    n))]

    -- | Build lenses (and traversals) with a sensible default configuration.
    --
    -- /e.g./
    --
    -- @
    -- data FooBar
    --   = Foo { _x, _y :: 'Int' }
    --   | Bar { _x :: 'Int' }
    -- 'makeLenses' ''FooBar
    -- @
    --
    -- will create
    --
    -- @
    -- x :: 'Lens'' FooBar 'Int'
    -- x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a
    -- x f (Bar a)   = Bar \<$\> f a
    -- y :: 'Traversal'' FooBar 'Int'
    -- y f (Foo a b) = (\\b\' -> Foo a  b\') \<$\> f b
    -- y _ c\@(Bar _) = pure c
    -- @
    --
    -- @
    -- 'makeLenses' = 'makeLensesWith' 'lensRules'
    -- @
    makeLenses :: Name -> DecsQ
    makeLenses :: Name -> DecsQ
    makeLenses = LensRules -> Name -> DecsQ
    makeFieldOptics LensRules
    lensRules

    -- | 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 t where
    --   foo :: 'Lens'' t Foo
    --   fooX :: 'Lens'' t 'Int'
    --   fooX = foo . go where go f (Foo x y) = (\\x\' -> Foo x' y) \<$\> f x
    --   fooY :: 'Lens'' t 'Int'
    --   fooY = foo . go where go f (Foo x y) = (\\y\' -> Foo x y') \<$\> f y
    -- instance HasFoo Foo where
    --   foo = id
    -- @
    --
    -- @
    -- 'makeClassy' = 'makeLensesWith' 'classyRules'
    -- @
    makeClassy :: Name -> DecsQ
    makeClassy :: Name -> DecsQ
    makeClassy = LensRules -> Name -> DecsQ
    makeFieldOptics LensRules
    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_ :: Name -> DecsQ
    makeClassy_ = LensRules -> Name -> DecsQ
    makeFieldOptics LensRules
    classyRules_

    -- | Derive lenses and traversals, specifying explicit pairings
    -- of @(fieldName, lensName)@.
    --
    -- If you map multiple names to the same label, and it is present in the same
    -- constructor then this will generate a 'Traversal'.
    --
    -- /e.g./
    --
    -- @
    -- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo
    -- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar
    -- @
    makeLensesFor :: [(String, String)] -> Name -> DecsQ
    makeLensesFor :: [(String, String)] -> Name -> DecsQ
    makeLensesFor [(String, String)]
    fields = LensRules -> Name -> DecsQ
    makeFieldOptics ([(String, String)] -> LensRules
    lensRulesFor [(String, String)]
    fields)

    -- | 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 :: String -> String -> [(String, String)] -> Name -> DecsQ
    makeClassyFor String
    clsName String
    funName [(String, String)]
    fields = LensRules -> Name -> DecsQ
    makeFieldOptics (LensRules -> Name -> DecsQ) -> LensRules -> Name -> DecsQ
    forall a b. (a -> b) -> a -> b
    $
      (String -> Maybe (String, String))
    -> [(String, String)] -> LensRules
    classyRulesFor (Maybe (String, String) -> String -> Maybe (String, String)
    forall a b. a -> b -> a
    const ((String, String) -> Maybe (String, String)
    forall a. a -> Maybe a
    Just (String
    clsName, String
    funName))) [(String, String)]
    fields

    -- | Build lenses with a custom configuration.
    makeLensesWith :: LensRules -> Name -> DecsQ
    makeLensesWith :: LensRules -> Name -> DecsQ
    makeLensesWith = LensRules -> Name -> DecsQ
    makeFieldOptics

    -- | Make lenses 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 :: DecsQ -> DecsQ
    declareLenses
      = LensRules -> DecsQ -> DecsQ
    declareLensesWith
      (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ LensRules
    lensRules
      LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ \Name
    _ [Name]
    _ Name
    n -> [Name -> DefName
    TopName Name
    n]

    -- | Similar to 'makeLensesFor', but takes a declaration quote.
    declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
    declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
    declareLensesFor [(String, String)]
    fields
      = LensRules -> DecsQ -> DecsQ
    declareLensesWith
      (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ [(String, String)] -> LensRules
    lensRulesFor [(String, String)]
    fields
      LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ \Name
    _ [Name]
    _ Name
    n -> [Name -> DefName
    TopName Name
    n]

    -- | 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 :: DecsQ -> DecsQ
    declareClassy
      = LensRules -> DecsQ -> DecsQ
    declareLensesWith
      (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ LensRules
    classyRules
      LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ \Name
    _ [Name]
    _ Name
    n -> [Name -> DefName
    TopName Name
    n]

    -- | Similar to 'makeClassyFor', but takes a declaration quote.
    declareClassyFor ::
      [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ
    declareClassyFor :: [(String, (String, String))]
    -> [(String, String)] -> DecsQ -> DecsQ
    declareClassyFor [(String, (String, String))]
    classes [(String, String)]
    fields
      = LensRules -> DecsQ -> DecsQ
    declareLensesWith
      (LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ (String -> Maybe (String, String))
    -> [(String, String)] -> LensRules
    classyRulesFor (String -> [(String, (String, String))] -> Maybe (String, String)
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    `Prelude.lookup`[(String, (String, String))]
    classes) [(String, String)]
    fields
      LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ \Name
    _ [Name]
    _ Name
    n -> [Name -> DefName
    TopName Name
    n]

    -- | 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 :: DecsQ -> DecsQ
    declarePrisms = (Dec -> Declare Dec) -> DecsQ -> DecsQ
    declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
    -> (Dec -> Declare Dec) -> DecsQ -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ \Dec
    dec -> do
      [Dec] -> Declare ()
    emit ([Dec] -> Declare ())
    -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< DecsQ -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
    forall a. Q a -> Declare a
    liftDeclare (Bool -> Dec -> DecsQ
    makeDecPrisms Bool
    True Dec
    dec)
      Dec -> Declare Dec
    forall a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Dec
    dec

    -- | Build 'Control.Lens.Wrapped.Wrapped' instance for each newtype.
    declareWrapped :: DecsQ -> DecsQ
    declareWrapped :: DecsQ -> DecsQ
    declareWrapped = (Dec -> Declare Dec) -> DecsQ -> DecsQ
    declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
    -> (Dec -> Declare Dec) -> DecsQ -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ \Dec
    dec -> do
      Maybe [Dec]
    maybeDecs <- Q (Maybe [Dec]) -> Declare (Maybe [Dec])
    forall a. Q a -> Declare a
    liftDeclare (Q (Maybe [Dec]) -> Declare (Maybe [Dec]))
    -> Q (Maybe [Dec]) -> Declare (Maybe [Dec])
    forall a b. (a -> b) -> a -> b
    $ do
        DatatypeInfo
    inf <- Dec -> Q DatatypeInfo
    normalizeDec Dec
    dec
        DatatypeInfo -> Q (Maybe [Dec])
    makeWrappedForDatatypeInfo DatatypeInfo
    inf
      Maybe [Dec] -> ([Dec] -> Declare ()) -> Declare ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ Maybe [Dec]
    maybeDecs [Dec] -> Declare ()
    emit
      Dec -> Declare Dec
    forall a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Dec
    dec

    -- | @ declareFields = 'declareLensesWith' 'defaultFieldRules' @
    declareFields :: DecsQ -> DecsQ
    declareFields :: DecsQ -> DecsQ
    declareFields = LensRules -> DecsQ -> DecsQ
    declareLensesWith LensRules
    defaultFieldRules

    -- | Declare lenses for each records in the given declarations, using the
    -- specified 'LensRules'. Any record syntax in the input will be stripped
    -- off.
    declareLensesWith :: LensRules -> DecsQ -> DecsQ
    declareLensesWith :: LensRules -> DecsQ -> DecsQ
    declareLensesWith LensRules
    rules = (Dec -> Declare Dec) -> DecsQ -> DecsQ
    declareWith ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
    -> (Dec -> Declare Dec) -> DecsQ -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ \Dec
    dec -> do
      [Dec] -> Declare ()
    emit ([Dec] -> Declare ())
    -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< StateT (Set Name) Q [Dec]
    -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
    forall (m :: * -> *) a. Monad m => m a -> WriterT (Endo [Dec]) m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (LensRules -> Dec -> StateT (Set Name) Q [Dec]
    makeFieldOpticsForDec' LensRules
    rules Dec
    dec)
      Dec -> Declare Dec
    forall a. a -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Dec -> Declare Dec) -> Dec -> Declare Dec
    forall a b. (a -> b) -> a -> b
    $ Dec -> Dec
    stripFields Dec
    dec

    -----------------------------------------------------------------------------
    -- Internal TH Implementation
    -----------------------------------------------------------------------------

    -- | Given a set of names, build a map from those names to a set of fresh names
    -- based on them.
    freshMap :: Set Name -> Q (Map Name Name)
    freshMap :: Set Name -> Q (Map Name Name)
    freshMap Set Name
    ns = [(Name, Name)] -> Map Name Name
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(Name, Name)] -> Map Name Name)
    -> Q [(Name, Name)] -> Q (Map Name Name)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name] -> (Name -> Q (Name, Name)) -> Q [(Name, Name)]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    t a -> (a -> f b) -> f (t b)
    for (Set Name -> [Name]
    forall a. Set a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList Set Name
    ns) (\ Name
    n -> (,) Name
    n (Name -> (Name, Name)) -> Q Name -> Q (Name, Name)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName (Name -> String
    nameBase Name
    n))

    apps :: Type -> [Type] -> Type
    apps :: Type -> [Type] -> Type
    apps = (Type -> Type -> Type) -> Type -> [Type] -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    Prelude.foldl Type -> Type -> Type
    AppT

    -- | Build 'Wrapped' instance for a given newtype
    makeWrapped :: Name -> DecsQ
    makeWrapped :: Name -> DecsQ
    makeWrapped Name
    nm = do
      DatatypeInfo
    inf <- Name -> Q DatatypeInfo
    reifyDatatype Name
    nm
      Maybe [Dec]
    maybeDecs <- DatatypeInfo -> Q (Maybe [Dec])
    makeWrappedForDatatypeInfo DatatypeInfo
    inf
      DecsQ -> ([Dec] -> DecsQ) -> Maybe [Dec] -> DecsQ
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> DecsQ
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "makeWrapped: Unsupported data type") [Dec] -> DecsQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe [Dec]
    maybeDecs

    makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])
    makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])
    makeWrappedForDatatypeInfo dataInfo :: DatatypeInfo
    dataInfo@(DatatypeInfo{datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons = [ConstructorInfo]
    cons})
      | [conInfo :: ConstructorInfo
    conInfo@(ConstructorInfo{constructorFields :: ConstructorInfo -> [Type]
    constructorFields = [Type]
    fields})] <- [ConstructorInfo]
    cons
      , [Type
    field] <- [Type]
    fields
      = do Dec
    wrapped   <- DatatypeInfo -> ConstructorInfo -> Type -> DecQ
    makeWrappedInstance DatatypeInfo
    dataInfo ConstructorInfo
    conInfo Type
    field
           Dec
    rewrapped <- DatatypeInfo -> DecQ
    makeRewrappedInstance DatatypeInfo
    dataInfo
           Maybe [Dec] -> Q (Maybe [Dec])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Dec] -> Maybe [Dec]
    forall a. a -> Maybe a
    Just [Dec
    rewrapped, Dec
    wrapped])

      | Bool
    otherwise = Maybe [Dec] -> Q (Maybe [Dec])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe [Dec]
    forall a. Maybe a
    Nothing

    makeRewrappedInstance :: DatatypeInfo -> DecQ
    makeRewrappedInstance :: DatatypeInfo -> DecQ
    makeRewrappedInstance DatatypeInfo
    dataInfo = do

       Q Type
    t <- Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT (Name -> Q Type) -> Q Name -> Q (Q Type)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "t"

       let typeArgs :: [Name]
    typeArgs = (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (Getting Name (TyVarBndr ()) Name -> TyVarBndr () -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name (TyVarBndr ()) Name
    forall t. HasName t => Lens' t Name
    Lens' (TyVarBndr ()) Name
    name) (DatatypeInfo -> [TyVarBndr ()]
    datatypeVars DatatypeInfo
    dataInfo)

       [Name]
    typeArgs' <- do
         Map Name Name
    m <- Set Name -> Q (Map Name Name)
    freshMap ([Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    Set.fromList [Name]
    typeArgs)
         [Name] -> Q [Name]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Name -> [Name] -> [Name]
    forall t. HasTypeVars t => Map Name Name -> t -> t
    substTypeVars Map Name Name
    m [Name]
    typeArgs)

           -- Con a b c...
       let appliedType :: Q Type
    appliedType  = Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DatatypeInfo -> [Type] -> Type
    applyDatatypeToArgs DatatypeInfo
    dataInfo ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    typeArgs))

           -- Con a' b' c'...
           appliedType' :: Q Type
    appliedType' = Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DatatypeInfo -> [Type] -> Type
    applyDatatypeToArgs DatatypeInfo
    dataInfo ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    typeArgs'))

           -- Con a' b' c'... ~ t
           eq :: Q Type
    eq = Type -> Type -> Type
    AppT(Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type -> Type
    AppT Type
    EqualityT (Type -> Type -> Type) -> Q Type -> Q (Type -> Type)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Q Type
    appliedType' Q (Type -> Type) -> Q Type -> Q Type
    forall a b. Q (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Q Type
    t

           -- Rewrapped (Con a b c...) t
           klass :: Q Type
    klass = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    rewrappedTypeName Q Type -> [Q Type] -> Q Type
    `appsT` [Q Type
    appliedType, Q Type
    t]

       -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t
       Q [Type] -> Q Type -> [DecQ] -> DecQ
    forall (m :: * -> *).
    Quote m =>
    m [Type] -> m Type -> [m Dec] -> m Dec
    instanceD ([Q Type] -> Q [Type]
    forall (m :: * -> *). Quote m => [m Type] -> m [Type]
    cxt [Q Type
    eq]) Q Type
    klass []

    makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ
    makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ
    makeWrappedInstance DatatypeInfo
    dataInfo ConstructorInfo
    conInfo Type
    fieldType = do

      let conName :: Name
    conName = ConstructorInfo -> Name
    constructorName ConstructorInfo
    conInfo
      let typeArgs :: [Name]
    typeArgs = Getting (Endo [Name]) [TyVarBndr ()] Name
    -> [TyVarBndr ()] -> [Name]
    forall a s. Getting (Endo [a]) s a -> s -> [a]
    toListOf Getting (Endo [Name]) [TyVarBndr ()] Name
    forall t. HasTypeVars t => Traversal' t Name
    Traversal' [TyVarBndr ()] Name
    typeVars (DatatypeInfo -> [TyVarBndr ()]
    datatypeVars DatatypeInfo
    dataInfo)

      -- Con a b c...
      let appliedType :: Type
    appliedType  = DatatypeInfo -> [Type] -> Type
    applyDatatypeToArgs DatatypeInfo
    dataInfo ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    typeArgs)

      -- type Unwrapped (Con a b c...) = $fieldType
      let unwrappedATF :: DecQ
    unwrappedATF = Name -> Maybe [Q (TyVarBndr ())] -> [Q Type] -> Q Type -> DecQ
    tySynInstDCompat Name
    unwrappedTypeName Maybe [Q (TyVarBndr ())]
    forall a. Maybe a
    Nothing
                           [Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    appliedType] (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    fieldType)

      -- Wrapped (Con a b c...)
      let klass :: Q Type
    klass        = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    wrappedTypeName Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    appliedType

      -- _Wrapped' = iso (\(Con x) -> x) Con
      let wrapFun :: Q Exp
    wrapFun      = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conName
      let unwrapFun :: Q Exp
    unwrapFun    = String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x" Q Name -> (Name -> Q Exp) -> Q Exp
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Name
    x -> Q Pat -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
    lam1E (Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP Name
    conName [Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    x]) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    x)
      let body :: Q Exp
    body         = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE [Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    isoValName, Q Exp
    unwrapFun, Q Exp
    wrapFun]
      let isoMethod :: DecQ
    isoMethod    = Name -> [Q Clause] -> DecQ
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD Name
    _wrapped'ValName [[Q Pat] -> Q Body -> [DecQ] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [] (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB Q Exp
    body) []]

      -- instance Wrapped (Con a b c...) where
      --   type Unwrapped (Con a b c...) = fieldType
      --   _Wrapped' = iso (\(Con x) -> x) Con
      Q [Type] -> Q Type -> [DecQ] -> DecQ
    forall (m :: * -> *).
    Quote m =>
    m [Type] -> m Type -> [m Dec] -> m Dec
    instanceD ([Q Type] -> Q [Type]
    forall (m :: * -> *). Quote m => [m Type] -> m [Type]
    cxt []) Q Type
    klass [DecQ
    unwrappedATF, DecQ
    isoMethod]

    -- | Apply the 'datatypeName' of a 'DatatypeInfo' to some argument 'Type's,
    -- which are used to instantiate its 'datatypeVars'.
    applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type
    applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type
    applyDatatypeToArgs di :: DatatypeInfo
    di@(DatatypeInfo { datatypeName :: DatatypeInfo -> Name
    datatypeName = Name
    nm
                                         , datatypeVars :: DatatypeInfo -> [TyVarBndr ()]
    datatypeVars = [TyVarBndr ()]
    vars
                                         , datatypeInstTypes :: DatatypeInfo -> [Type]
    datatypeInstTypes = [Type]
    instTypes
                                         }) [Type]
    args =
      Type -> [Type] -> Type
    apps (Name -> Type
    ConT Name
    nm) ([Type] -> Type) -> [Type] -> Type
    forall a b. (a -> b) -> a -> b
    $
      -- Drop kind signatures if possible to reduce the likelihood of needing to
      -- enable KindSignatures. The likelihood is already quite small, however.
      -- This function is only used for the benefit of {make,declare}Wrapped, and
      -- one needs to enable TypeFamilies in order for the generated code to
      -- typecheck. Since TypeFamilies implies KindSignatures, dropping kind
      -- signatures is probably not required, but better to be safe then sorry.
      DatatypeInfo -> [Type] -> [Type]
    dropSigsIfNonDataFam DatatypeInfo
    di ([Type] -> [Type]) -> [Type] -> [Type]
    forall a b. (a -> b) -> a -> b
    $
      Map Name Type -> [Type] -> [Type]
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution ([(Name, Type)] -> Map Name Type
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([Name] -> [Type] -> [(Name, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr () -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName [TyVarBndr ()]
    vars) [Type]
    args)) [Type]
    instTypes

    overHead :: (a -> a) -> [a] -> [a]
    overHead :: forall a. (a -> a) -> [a] -> [a]
    overHead a -> a
    _ []     = []
    overHead a -> a
    f (a
    x:[a]
    xs) = a -> a
    f a
    x a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    : [a]
    xs

    -- | Field rules for fields in the form @ _prefix_fieldname @
    underscoreFields :: LensRules
    underscoreFields :: LensRules
    underscoreFields = LensRules
    defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ FieldNamer
    underscoreNamer

    -- | A 'FieldNamer' for 'underscoreFields'.
    underscoreNamer :: FieldNamer
    underscoreNamer :: FieldNamer
    underscoreNamer Name
    _ [Name]
    _ Name
    field = Maybe DefName -> [DefName]
    forall a. Maybe a -> [a]
    maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
    forall a b. (a -> b) -> a -> b
    $ do
      String
    _      <- String -> Maybe String
    prefix String
    field'
      String
    method <- Maybe String
    niceLens
      String
    cls    <- Maybe String
    classNaming
      DefName -> Maybe DefName
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Name -> DefName
    MethodName (String -> Name
    mkName String
    cls) (String -> Name
    mkName String
    method))
      where
        field' :: String
    field' = Name -> String
    nameBase Name
    field
        prefix :: String -> Maybe String
    prefix (Char
    '_':String
    xs) | Char
    '_' Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `List.elem` String
    xs = String -> Maybe String
    forall a. a -> Maybe a
    Just ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '_') String
    xs)
        prefix String
    _                             = Maybe String
    forall a. Maybe a
    Nothing
        niceLens :: Maybe String
    niceLens    = String -> Maybe String
    prefix String
    field' Maybe String -> (String -> String) -> Maybe String
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \String
    n -> Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    2) String
    field'
        classNaming :: Maybe String
    classNaming = Maybe String
    niceLens Maybe String -> (String -> String) -> Maybe String
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> (String
    "Has_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++)

    -- | 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 :: LensRules
    camelCaseFields = LensRules
    defaultFieldRules

    -- | A 'FieldNamer' for 'camelCaseFields'.
    camelCaseNamer :: FieldNamer
    camelCaseNamer :: FieldNamer
    camelCaseNamer Name
    tyName [Name]
    fields Name
    field = Maybe DefName -> [DefName]
    forall a. Maybe a -> [a]
    maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
    forall a b. (a -> b) -> a -> b
    $ do

      String
    fieldPart <- String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    List.stripPrefix String
    expectedPrefix (Name -> String
    nameBase Name
    field)
      String
    method    <- String -> Maybe String
    computeMethod String
    fieldPart
      let cls :: String
    cls = String
    "Has" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    fieldPart
      DefName -> Maybe DefName
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Name -> DefName
    MethodName (String -> Name
    mkName String
    cls) (String -> Name
    mkName String
    method))

      where
      expectedPrefix :: String
    expectedPrefix = String
    optUnderscore String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Char -> Char) -> String -> String
    forall a. (a -> a) -> [a] -> [a]
    overHead Char -> Char
    toLower (Name -> String
    nameBase Name
    tyName)

      optUnderscore :: String
    optUnderscore  = [Char
    '_' | (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    List.isPrefixOf String
    "_" (String -> Bool) -> (Name -> String) -> Name -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase) [Name]
    fields ]

      computeMethod :: String -> Maybe String
    computeMethod (Char
    x:String
    xs) | Char -> Bool
    isUpper Char
    x = String -> Maybe String
    forall a. a -> Maybe a
    Just (Char -> Char
    toLower Char
    x Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    xs)
      computeMethod String
    _                  = Maybe String
    forall a. Maybe a
    Nothing

    -- | 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 :: LensRules
    classUnderscoreNoPrefixFields =
      LensRules
    defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
    forall a b. a -> (a -> b) -> b
    & (FieldNamer -> Identity FieldNamer)
    -> LensRules -> Identity LensRules
    Lens' LensRules FieldNamer
    lensField ((FieldNamer -> Identity FieldNamer)
     -> LensRules -> Identity LensRules)
    -> FieldNamer -> LensRules -> LensRules
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ FieldNamer
    classUnderscoreNoPrefixNamer

    -- | A 'FieldNamer' for 'classUnderscoreNoPrefixFields'.
    classUnderscoreNoPrefixNamer :: FieldNamer
    classUnderscoreNoPrefixNamer :: FieldNamer
    classUnderscoreNoPrefixNamer Name
    _ [Name]
    _ Name
    field = Maybe DefName -> [DefName]
    forall a. Maybe a -> [a]
    maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
    forall a b. (a -> b) -> a -> b
    $ do
      String
    fieldUnprefixed <- String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    List.stripPrefix String
    "_" (Name -> String
    nameBase Name
    field)
      let className :: String
    className  = String
    "Has" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Char -> Char) -> String -> String
    forall a. (a -> a) -> [a] -> [a]
    overHead Char -> Char
    toUpper String
    fieldUnprefixed
          methodName :: String
    methodName = String
    fieldUnprefixed
      DefName -> Maybe DefName
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Name -> DefName
    MethodName (String -> Name
    mkName String
    className) (String -> Name
    mkName String
    methodName))

    -- | 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 :: LensRules
    abbreviatedFields = LensRules
    defaultFieldRules { _fieldToDef :: FieldNamer
    _fieldToDef = FieldNamer
    abbreviatedNamer }

    -- | A 'FieldNamer' for 'abbreviatedFields'.
    abbreviatedNamer :: FieldNamer
    abbreviatedNamer :: FieldNamer
    abbreviatedNamer Name
    _ [Name]
    fields Name
    field = Maybe DefName -> [DefName]
    forall a. Maybe a -> [a]
    maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
    forall a b. (a -> b) -> a -> b
    $ do

      String
    fieldPart <- String -> Maybe String
    stripMaxLc (Name -> String
    nameBase Name
    field)
      String
    method    <- String -> Maybe String
    computeMethod String
    fieldPart
      let cls :: String
    cls = String
    "Has" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    fieldPart
      DefName -> Maybe DefName
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Name -> DefName
    MethodName (String -> Name
    mkName String
    cls) (String -> Name
    mkName String
    method))

      where
      stripMaxLc :: String -> Maybe String
    stripMaxLc String
    f = do String
    x <- String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    List.stripPrefix String
    optUnderscore String
    f
                        case (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break Char -> Bool
    isUpper String
    x of
                          (String
    p,String
    s) | String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    List.null String
    p Bool -> Bool -> Bool
    || String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    List.null String
    s -> Maybe String
    forall a. Maybe a
    Nothing
                                | Bool
    otherwise                  -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    s
      optUnderscore :: String
    optUnderscore  = [Char
    '_' | (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    List.isPrefixOf String
    "_" (String -> Bool) -> (Name -> String) -> Name -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase) [Name]
    fields ]

      computeMethod :: String -> Maybe String
    computeMethod (Char
    x:String
    xs) | Char -> Bool
    isUpper Char
    x = String -> Maybe String
    forall a. a -> Maybe a
    Just (Char -> Char
    toLower Char
    x Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    xs)
      computeMethod String
    _                  = Maybe String
    forall a. Maybe a
    Nothing

    -- | 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
    --
    -- @
    -- _fooXLens :: Lens' (Foo a) Int
    -- _fooYLens :: Lens (Foo a) (Foo b) a b
    -- class HasX s a | s -> a where
    --   x :: Lens' s a
    -- instance HasX (Foo a) Int where
    --   x = _fooXLens
    -- class HasY s a | s -> a where
    --   y :: Lens' s a
    -- instance HasY (Foo a) a where
    --   y = _fooYLens
    -- _barXLens :: Iso' Bar Char
    -- instance HasX Bar Char where
    --   x = _barXLens
    -- @
    --
    -- For details, see 'camelCaseFields'.
    --
    -- @
    -- makeFields = 'makeLensesWith' 'defaultFieldRules'
    -- @
    makeFields :: Name -> DecsQ
    makeFields :: Name -> DecsQ
    makeFields = LensRules -> Name -> DecsQ
    makeFieldOptics LensRules
    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 :: Name -> DecsQ
    makeFieldsNoPrefix = LensRules -> Name -> DecsQ
    makeFieldOptics LensRules
    classUnderscoreNoPrefixFields

    defaultFieldRules :: LensRules
    defaultFieldRules :: LensRules
    defaultFieldRules = LensRules
      { _simpleLenses :: Bool
    _simpleLenses    = Bool
    True
      , _generateSigs :: Bool
    _generateSigs    = Bool
    True
      , _generateClasses :: Bool
    _generateClasses = Bool
    True  -- classes will still be skipped if they already exist
      , _allowIsos :: Bool
    _allowIsos       = Bool
    False -- generating Isos would hinder field class reuse
      , _allowUpdates :: Bool
    _allowUpdates    = Bool
    True
      , _lazyPatterns :: Bool
    _lazyPatterns    = Bool
    False
      , _recordSyntax :: Bool
    _recordSyntax    = Bool
    False
      , _classyLenses :: ClassyNamer
    _classyLenses    = Maybe (Name, Name) -> ClassyNamer
    forall a b. a -> b -> a
    const Maybe (Name, Name)
    forall a. Maybe a
    Nothing
      , _fieldToDef :: FieldNamer
    _fieldToDef      = FieldNamer
    camelCaseNamer
      }

    -- Declaration quote stuff

    declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
    declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
    declareWith Dec -> Declare Dec
    fun = (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
    runDeclare (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ)
    -> ([Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec])
    -> [Dec]
    -> DecsQ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Dec -> Declare Dec)
    -> [Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
    forall (f :: * -> *).
    Applicative f =>
    (Dec -> f Dec) -> [Dec] -> f [Dec]
    traverseDataAndNewtype Dec -> Declare Dec
    fun ([Dec] -> DecsQ) -> DecsQ -> DecsQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<<)

    -- | 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 :: forall a. Q a -> Declare a
    liftDeclare = StateT (Set Name) Q a
    -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
    forall (m :: * -> *) a. Monad m => m a -> WriterT (Endo [Dec]) m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (StateT (Set Name) Q a
     -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a)
    -> (Q a -> StateT (Set Name) Q a)
    -> Q a
    -> WriterT (Endo [Dec]) (StateT (Set Name) Q) a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Q a -> StateT (Set Name) Q a
    forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift

    runDeclare :: Declare [Dec] -> DecsQ
    runDeclare :: WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
    runDeclare WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
    dec = do
      ([Dec]
    out, Endo [Dec]
    endo) <- StateT (Set Name) Q ([Dec], Endo [Dec])
    -> Set Name -> Q ([Dec], Endo [Dec])
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
    evalStateT (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
    -> StateT (Set Name) Q ([Dec], Endo [Dec])
    forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
    runWriterT WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
    dec) Set Name
    forall a. Set a
    Set.empty
      [Dec] -> DecsQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ [Dec]
    out [Dec] -> [Dec] -> [Dec]
    forall a. [a] -> [a] -> [a]
    ++ Endo [Dec] -> [Dec] -> [Dec]
    forall a. Endo a -> a -> a
    appEndo Endo [Dec]
    endo []

    emit :: [Dec] -> Declare ()
    emit :: [Dec] -> Declare ()
    emit [Dec]
    decs = Endo [Dec] -> Declare ()
    forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
    tell (Endo [Dec] -> Declare ()) -> Endo [Dec] -> Declare ()
    forall a b. (a -> b) -> a -> b
    $ ([Dec] -> [Dec]) -> Endo [Dec]
    forall a. (a -> a) -> Endo a
    Endo ([Dec]
    decs[Dec] -> [Dec] -> [Dec]
    forall a. [a] -> [a] -> [a]
    ++)

    -- | Traverse each data, newtype, data instance or newtype instance
    -- declaration.
    traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]
    traverseDataAndNewtype :: forall (f :: * -> *).
    Applicative f =>
    (Dec -> f Dec) -> [Dec] -> f [Dec]
    traverseDataAndNewtype Dec -> f Dec
    f = (Dec -> f Dec) -> [Dec] -> f [Dec]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse Dec -> f Dec
    go
      where
        go :: Dec -> f Dec
    go Dec
    dec = case Dec
    dec of
          DataD{} -> Dec -> f Dec
    f Dec
    dec
          NewtypeD{} -> Dec -> f Dec
    f Dec
    dec
          DataInstD{} -> Dec -> f Dec
    f Dec
    dec
          NewtypeInstD{} -> Dec -> f Dec
    f Dec
    dec

          -- Recurse into instance declarations because they main contain
          -- associated data family instances.
          InstanceD Maybe Overlap
    moverlap [Type]
    ctx Type
    inst [Dec]
    body -> Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    moverlap [Type]
    ctx Type
    inst ([Dec] -> Dec) -> f [Dec] -> f Dec
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Dec -> f Dec) -> [Dec] -> f [Dec]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse Dec -> f Dec
    go [Dec]
    body
          Dec
    _ -> Dec -> f Dec
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Dec
    dec

    stripFields :: Dec -> Dec
    stripFields :: Dec -> Dec
    stripFields Dec
    dec = case Dec
    dec of
      DataD [Type]
    ctx Name
    tyName [TyVarBndr ()]
    tyArgs Maybe Type
    kind [Con]
    cons [DerivClause]
    derivings ->
        [Type]
    -> Name
    -> [TyVarBndr ()]
    -> Maybe Type
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataD [Type]
    ctx Name
    tyName [TyVarBndr ()]
    tyArgs Maybe Type
    kind ((Con -> Con) -> [Con] -> [Con]
    forall a b. (a -> b) -> [a] -> [b]
    map Con -> Con
    deRecord [Con]
    cons) [DerivClause]
    derivings
      NewtypeD [Type]
    ctx Name
    tyName [TyVarBndr ()]
    tyArgs Maybe Type
    kind Con
    con [DerivClause]
    derivings ->
        [Type]
    -> Name
    -> [TyVarBndr ()]
    -> Maybe Type
    -> Con
    -> [DerivClause]
    -> Dec
    NewtypeD [Type]
    ctx Name
    tyName [TyVarBndr ()]
    tyArgs Maybe Type
    kind (Con -> Con
    deRecord Con
    con) [DerivClause]
    derivings
      DataInstD [Type]
    ctx Maybe [TyVarBndr ()]
    tyName Type
    tyArgs Maybe Type
    kind [Con]
    cons [DerivClause]
    derivings ->
        [Type]
    -> Maybe [TyVarBndr ()]
    -> Type
    -> Maybe Type
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataInstD [Type]
    ctx Maybe [TyVarBndr ()]
    tyName Type
    tyArgs Maybe Type
    kind ((Con -> Con) -> [Con] -> [Con]
    forall a b. (a -> b) -> [a] -> [b]
    map Con -> Con
    deRecord [Con]
    cons) [DerivClause]
    derivings
      NewtypeInstD [Type]
    ctx Maybe [TyVarBndr ()]
    tyName Type
    tyArgs Maybe Type
    kind Con
    con [DerivClause]
    derivings ->
        [Type]
    -> Maybe [TyVarBndr ()]
    -> Type
    -> Maybe Type
    -> Con
    -> [DerivClause]
    -> Dec
    NewtypeInstD [Type]
    ctx Maybe [TyVarBndr ()]
    tyName Type
    tyArgs Maybe Type
    kind (Con -> Con
    deRecord Con
    con) [DerivClause]
    derivings
      Dec
    _ -> Dec
    dec

    deRecord :: Con -> Con
    deRecord :: Con -> Con
    deRecord con :: Con
    con@NormalC{} = Con
    con
    deRecord con :: Con
    con@InfixC{} = Con
    con
    deRecord (ForallC [TyVarBndr Specificity]
    tyVars [Type]
    ctx Con
    con) = [TyVarBndr Specificity] -> [Type] -> Con -> Con
    ForallC [TyVarBndr Specificity]
    tyVars [Type]
    ctx (Con -> Con) -> Con -> Con
    forall a b. (a -> b) -> a -> b
    $ Con -> Con
    deRecord Con
    con
    deRecord (RecC Name
    conName [VarBangType]
    fields) = Name -> [BangType] -> Con
    NormalC Name
    conName ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
    forall a b. (a -> b) -> [a] -> [b]
    map VarBangType -> BangType
    dropFieldName [VarBangType]
    fields)
    deRecord con :: Con
    con@GadtC{} = Con
    con
    deRecord (RecGadtC [Name]
    ns [VarBangType]
    fields Type
    retTy) = [Name] -> [BangType] -> Type -> Con
    GadtC [Name]
    ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
    forall a b. (a -> b) -> [a] -> [b]
    map VarBangType -> BangType
    dropFieldName [VarBangType]
    fields) Type
    retTy

    dropFieldName :: VarBangType -> BangType
    dropFieldName :: VarBangType -> BangType
    dropFieldName (Name
    _, Bang
    str, Type
    typ) = (Bang
    str, Type
    typ)