    {-# LANGUAGE CPP #-}
    {-# LANGUAGE PatternGuards #-}
    #if __GLASGOW_HASKELL__ >= 800
    {-# LANGUAGE TemplateHaskellQuotes #-}
    #else
    {-# LANGUAGE TemplateHaskell #-}
    #endif
    #ifdef TRUSTWORTHY
    # if MIN_VERSION_template_haskell(2,12,0)
    {-# LANGUAGE Safe #-}
    # else
    {-# LANGUAGE Trustworthy #-}
    # endif
    #endif

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Lens.Internal.FieldTH
    -- Copyright   :  (C) 2014-2016 Edward Kmett, (C) 2014 Eric Mertens
    -- License     :  BSD-style (see the file LICENSE)
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -----------------------------------------------------------------------------

    module Control.Lens.Internal.FieldTH
      ( LensRules(..)
      , FieldNamer
      , DefName(..)
      , ClassyNamer
      , makeFieldOptics
      , makeFieldOpticsForDec
      , makeFieldOpticsForDec'
      , HasFieldClasses
      ) where

    import Prelude ()

    import Control.Lens.At
    import Control.Lens.Fold
    import Control.Lens.Indexed
    import Control.Lens.Internal.TH
    import Control.Lens.Internal.Prelude
    import Control.Lens.Lens
    import Control.Lens.Plated
    import Control.Lens.Prism
    import Control.Lens.Setter
    import Control.Lens.Getter
    import Control.Lens.Tuple
    import Control.Lens.Traversal
    import Control.Monad
    import Control.Monad.State
    import Language.Haskell.TH.Lens
    import Language.Haskell.TH
    import qualified Language.Haskell.TH.Datatype as D
    import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
    import Data.Maybe (fromMaybe,isJust,maybeToList)
    import Data.List (nub)
    import Data.Either (partitionEithers)
    import Data.Semigroup (Any (..))
    import Data.Set.Lens
    import           Data.Map ( Map )
    import           Data.Set ( Set )
    import qualified Data.Set as Set
    import qualified Data.Map as Map
    import qualified Data.Traversable as T

    ------------------------------------------------------------------------
    -- Field generation entry point
    ------------------------------------------------------------------------

    -- | Compute the field optics for the type identified by the given type name.
    -- Lenses will be computed when possible, Traversals otherwise.
    makeFieldOptics :: LensRules -> Name -> DecsQ
    makeFieldOptics :: LensRules -> Name -> DecsQ
    makeFieldOptics LensRules
    rules = (StateT (Set Name) Q [Dec] -> Set Name -> DecsQ
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
    `evalStateT` Set Name
    forall a. Set a
    Set.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
    -> (DatatypeInfo -> StateT (Set Name) Q [Dec])
    -> DatatypeInfo
    -> DecsQ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
    makeFieldOpticsForDatatype LensRules
    rules (DatatypeInfo -> DecsQ)
    -> (Name -> Q DatatypeInfo) -> Name -> DecsQ
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< Name -> Q DatatypeInfo
    D.reifyDatatype

    makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
    makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
    makeFieldOpticsForDec LensRules
    rules = (StateT (Set Name) Q [Dec] -> Set Name -> DecsQ
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
    `evalStateT` Set Name
    forall a. Set a
    Set.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
    -> (Dec -> StateT (Set Name) Q [Dec]) -> Dec -> DecsQ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LensRules -> Dec -> StateT (Set Name) Q [Dec]
    makeFieldOpticsForDec' LensRules
    rules

    makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec]
    makeFieldOpticsForDec' :: LensRules -> Dec -> StateT (Set Name) Q [Dec]
    makeFieldOpticsForDec' LensRules
    rules = LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
    makeFieldOpticsForDatatype LensRules
    rules (DatatypeInfo -> StateT (Set Name) Q [Dec])
    -> (Dec -> StateT (Set Name) Q DatatypeInfo)
    -> Dec
    -> StateT (Set Name) Q [Dec]
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo
    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 (Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo)
    -> (Dec -> Q DatatypeInfo)
    -> Dec
    -> StateT (Set Name) Q DatatypeInfo
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Dec -> Q DatatypeInfo
    D.normalizeDec

    -- | Compute the field optics for a deconstructed datatype Dec
    -- When possible build an Iso otherwise build one optic per field.
    makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]
    makeFieldOpticsForDatatype :: LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
    makeFieldOpticsForDatatype LensRules
    rules DatatypeInfo
    info =
      do perDef <- Q (Map
         DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> StateT
         (Set Name)
         Q
         (Map
            DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    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 (Q (Map
          DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     -> StateT
          (Set Name)
          Q
          (Map
             DefName
             (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
    -> Q (Map
            DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> StateT
         (Set Name)
         Q
         (Map
            DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    forall a b. (a -> b) -> a -> b
    $ do
           fieldCons <- (ConstructorInfo -> Q (Name, [(Maybe Name, Type)]))
    -> [ConstructorInfo] -> Q [(Name, [(Maybe Name, Type)])]
    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 ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
    normalizeConstructor [ConstructorInfo]
    cons
           let allFields  = Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
    -> [(Name, [(Maybe Name, Type)])] -> [Name]
    forall a s. Getting (Endo [a]) s a -> s -> [a]
    toListOf (((Name, [(Maybe Name, Type)])
     -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
    -> [(Name, [(Maybe Name, Type)])]
    -> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])]
    forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
    IndexedFold
      Int [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
    folded (((Name, [(Maybe Name, Type)])
      -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
     -> [(Name, [(Maybe Name, Type)])]
     -> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])])
    -> ((Name -> Const (Endo [Name]) Name)
        -> (Name, [(Maybe Name, Type)])
        -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
    -> Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
    -> (Name, [(Maybe Name, Type)])
    -> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens
      (Name, [(Maybe Name, Type)])
      (Name, [(Maybe Name, Type)])
      [(Maybe Name, Type)]
      [(Maybe Name, Type)]
    _2 (([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
     -> (Name, [(Maybe Name, Type)])
     -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
    -> ((Name -> Const (Endo [Name]) Name)
        -> [(Maybe Name, Type)]
        -> Const (Endo [Name]) [(Maybe Name, Type)])
    -> (Name -> Const (Endo [Name]) Name)
    -> (Name, [(Maybe Name, Type)])
    -> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
    -> [(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)]
    forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
    IndexedFold Int [(Maybe Name, Type)] (Maybe Name, Type)
    folded (((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
     -> [(Maybe Name, Type)]
     -> Const (Endo [Name]) [(Maybe Name, Type)])
    -> ((Name -> Const (Endo [Name]) Name)
        -> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
    -> (Name -> Const (Endo [Name]) Name)
    -> [(Maybe Name, Type)]
    -> Const (Endo [Name]) [(Maybe Name, Type)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Maybe Name -> Const (Endo [Name]) (Maybe Name))
    -> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type)
    forall s t a b. Field1 s t a b => Lens s t a b
    Lens
      (Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
    _1 ((Maybe Name -> Const (Endo [Name]) (Maybe Name))
     -> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
    -> ((Name -> Const (Endo [Name]) Name)
        -> Maybe Name -> Const (Endo [Name]) (Maybe Name))
    -> (Name -> Const (Endo [Name]) Name)
    -> (Maybe Name, Type)
    -> Const (Endo [Name]) (Maybe Name, Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name -> Const (Endo [Name]) Name)
    -> Maybe Name -> Const (Endo [Name]) (Maybe Name)
    forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
    IndexedFold Int (Maybe Name) Name
    folded) [(Name, [(Maybe Name, Type)])]
    fieldCons
           let defCons    = ASetter
      [(Name, [(Maybe Name, Type)])]
      [(Name, [([(DefName, Maybe Name)], Type)])]
      (Maybe Name)
      [(DefName, Maybe Name)]
    -> (Maybe Name -> [(DefName, Maybe Name)])
    -> [(Name, [(Maybe Name, Type)])]
    -> [(Name, [([(DefName, Maybe Name)], Type)])]
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over ASetter
      [(Name, [(Maybe Name, Type)])]
      [(Name, [([(DefName, Maybe Name)], Type)])]
      (Maybe Name)
      [(DefName, Maybe Name)]
    forall a b (f :: * -> *).
    Applicative f =>
    (a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
    normFieldLabels ([Name] -> Maybe Name -> [(DefName, Maybe Name)]
    expandName [Name]
    allFields) [(Name, [(Maybe Name, Type)])]
    fieldCons
               allDefs    = Getting
      (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
    -> [(Name, [([(DefName, Maybe Name)], Type)])] -> Set DefName
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf (([(DefName, Maybe Name)]
     -> Const (Set DefName) [(DefName, Maybe Name)])
    -> [(Name, [([(DefName, Maybe Name)], Type)])]
    -> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])]
    forall a b (f :: * -> *).
    Applicative f =>
    (a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
    normFieldLabels (([(DefName, Maybe Name)]
      -> Const (Set DefName) [(DefName, Maybe Name)])
     -> [(Name, [([(DefName, Maybe Name)], Type)])]
     -> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])])
    -> ((DefName -> Const (Set DefName) DefName)
        -> [(DefName, Maybe Name)]
        -> Const (Set DefName) [(DefName, Maybe Name)])
    -> Getting
         (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((DefName, Maybe Name)
     -> Const (Set DefName) (DefName, Maybe Name))
    -> [(DefName, Maybe Name)]
    -> Const (Set DefName) [(DefName, Maybe Name)]
    forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
    IndexedFold Int [(DefName, Maybe Name)] (DefName, Maybe Name)
    folded (((DefName, Maybe Name)
      -> Const (Set DefName) (DefName, Maybe Name))
     -> [(DefName, Maybe Name)]
     -> Const (Set DefName) [(DefName, Maybe Name)])
    -> ((DefName -> Const (Set DefName) DefName)
        -> (DefName, Maybe Name)
        -> Const (Set DefName) (DefName, Maybe Name))
    -> (DefName -> Const (Set DefName) DefName)
    -> [(DefName, Maybe Name)]
    -> Const (Set DefName) [(DefName, Maybe Name)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (DefName -> Const (Set DefName) DefName)
    -> (DefName, Maybe Name)
    -> Const (Set DefName) (DefName, Maybe Name)
    forall s t a b. Field1 s t a b => Lens s t a b
    Lens (DefName, Maybe Name) (DefName, Maybe Name) DefName DefName
    _1) [(Name, [([(DefName, Maybe Name)], Type)])]
    defCons
           T.sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs)

         let defs = Map
      DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map
      DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    perDef
         case _classyLenses rules tyName of
           Just (Name
    className, Name
    methodName) ->
             LensRules
    -> Name
    -> Name
    -> Type
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> StateT (Set Name) Q [Dec]
    makeClassyDriver LensRules
    rules Name
    className Name
    methodName Type
    s [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs
           Maybe (Name, Name)
    Nothing -> do decss <- ((DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     -> StateT (Set Name) Q [Dec])
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> StateT (Set Name) Q [[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 (LensRules
    -> (DefName,
        (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> StateT (Set Name) Q [Dec]
    makeFieldOptic LensRules
    rules) [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs
                         return (concat decss)

      where
      tyName :: Name
    tyName = DatatypeInfo -> Name
    D.datatypeName     DatatypeInfo
    info
      s :: Type
    s      = DatatypeInfo -> Type
    datatypeTypeKinded DatatypeInfo
    info
      cons :: [ConstructorInfo]
    cons   = DatatypeInfo -> [ConstructorInfo]
    D.datatypeCons     DatatypeInfo
    info

      -- Traverse the field labels of a normalized constructor
      normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b
      normFieldLabels :: forall a b (f :: * -> *).
    Applicative f =>
    (a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
    normFieldLabels = ((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
    -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
    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 (((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
     -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])])
    -> ((a -> f b) -> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
    -> (a -> f b)
    -> [(Name, [(a, Type)])]
    -> f [(Name, [(b, Type)])]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([(a, Type)] -> f [(b, Type)])
    -> (Name, [(a, Type)]) -> f (Name, [(b, Type)])
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens
      (Name, [(a, Type)]) (Name, [(b, Type)]) [(a, Type)] [(b, Type)]
    _2 (([(a, Type)] -> f [(b, Type)])
     -> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
    -> ((a -> f b) -> [(a, Type)] -> f [(b, Type)])
    -> (a -> f b)
    -> (Name, [(a, Type)])
    -> f (Name, [(b, Type)])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)]
    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 (((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)])
    -> ((a -> f b) -> (a, Type) -> f (b, Type))
    -> (a -> f b)
    -> [(a, Type)]
    -> f [(b, Type)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> f b) -> (a, Type) -> f (b, Type)
    forall s t a b. Field1 s t a b => Lens s t a b
    Lens (a, Type) (b, Type) a b
    _1

      -- Map a (possibly missing) field's name to zero-to-many optic definitions
      expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
      expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
    expandName [Name]
    allFields Maybe Name
    mName = (\DefName
    x -> (DefName
    x, Maybe Name
    mName)) (DefName -> (DefName, Maybe Name))
    -> [DefName] -> [(DefName, Maybe Name)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Maybe Name -> [Name]
    forall a. Maybe a -> [a]
    maybeToList Maybe Name
    mName [Name] -> (Name -> [DefName]) -> [DefName]
    forall a b. [a] -> (a -> [b]) -> [b]
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= LensRules -> FieldNamer
    _fieldToDef LensRules
    rules Name
    tyName [Name]
    allFields)

    -- | Normalized the Con type into a uniform positional representation,
    -- eliminating the variance between records, infix constructors, and normal
    -- constructors.
    normalizeConstructor ::
      D.ConstructorInfo ->
      Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type

    normalizeConstructor :: ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
    normalizeConstructor ConstructorInfo
    con =
      (Name, [(Maybe Name, Type)]) -> Q (Name, [(Maybe Name, Type)])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ConstructorInfo -> Name
    D.constructorName ConstructorInfo
    con,
              (Maybe Name -> Type -> (Maybe Name, Type))
    -> [Maybe Name] -> [Type] -> [(Maybe Name, Type)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Maybe Name -> Type -> (Maybe Name, Type)
    forall {b} {a}. HasTypeVars b => Maybe a -> b -> (Maybe a, b)
    checkForExistentials [Maybe Name]
    fieldNames (ConstructorInfo -> [Type]
    D.constructorFields ConstructorInfo
    con))
      where
        fieldNames :: [Maybe Name]
    fieldNames =
          case ConstructorInfo -> ConstructorVariant
    D.constructorVariant ConstructorInfo
    con of
            D.RecordConstructor [Name]
    xs -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Maybe Name
    forall a. a -> Maybe a
    Just [Name]
    xs
            ConstructorVariant
    D.NormalConstructor    -> Maybe Name -> [Maybe Name]
    forall a. a -> [a]
    repeat Maybe Name
    forall a. Maybe a
    Nothing
            ConstructorVariant
    D.InfixConstructor     -> Maybe Name -> [Maybe Name]
    forall a. a -> [a]
    repeat Maybe Name
    forall a. Maybe a
    Nothing

        -- Fields mentioning existentially quantified types are not
        -- elligible for TH generated optics.
        checkForExistentials :: Maybe a -> b -> (Maybe a, b)
    checkForExistentials Maybe a
    _ b
    fieldtype
          | (TyVarBndr_ () -> Bool) -> [TyVarBndr_ ()] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\TyVarBndr_ ()
    tv -> TyVarBndr_ () -> Name
    forall flag. TyVarBndr_ flag -> Name
    D.tvName TyVarBndr_ ()
    tv Name -> Set Name -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.member` Set Name
    used) [TyVarBndr_ ()]
    unallowable
          = (Maybe a
    forall a. Maybe a
    Nothing, b
    fieldtype)
          where
            used :: Set Name
    used        = Getting (Set Name) b Name -> b -> Set Name
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf Getting (Set Name) b Name
    forall t. HasTypeVars t => Traversal' t Name
    Traversal' b Name
    typeVars b
    fieldtype
            unallowable :: [TyVarBndr_ ()]
    unallowable = ConstructorInfo -> [TyVarBndr_ ()]
    D.constructorVars ConstructorInfo
    con
        checkForExistentials Maybe a
    fieldname b
    fieldtype = (Maybe a
    fieldname, b
    fieldtype)

    data OpticType = GetterType | LensType | IsoType

    -- | Compute the positional location of the fields involved in
    -- each constructor for a given optic definition as well as the
    -- type of clauses to generate and the type to annotate the declaration
    -- with.
    buildScaffold ::
      LensRules                                                                            ->
      Type                                        {- ^ outer type                       -} ->
      [(Name, [([(DefName, Maybe Name)], Type)])] {- ^ normalized constructors          -} ->
      DefName                                     {- ^ target definition                -} ->
      Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
                  {- ^ optic type, definition type, field count, target fields -}
    buildScaffold :: LensRules
    -> Type
    -> [(Name, [([(DefName, Maybe Name)], Type)])]
    -> DefName
    -> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    buildScaffold LensRules
    rules Type
    s [(Name, [([(DefName, Maybe Name)], Type)])]
    cons DefName
    defName =

      do (s',t,a,b) <- Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
    buildStab Type
    s (((Name, [Either Type Type]) -> [Either Type Type])
    -> [(Name, [Either Type Type])] -> [Either Type Type]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Name, [Either Type Type]) -> [Either Type Type]
    forall a b. (a, b) -> b
    snd ([(Name, [Either Type (Maybe Name, Type)])]
    consForDef [(Name, [Either Type (Maybe Name, Type)])]
    -> ((Name, [Either Type (Maybe Name, Type)])
        -> (Name, [Either Type Type]))
    -> [(Name, [Either Type Type])]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> ([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
    -> (Name, [Either Type (Maybe Name, Type)])
    -> Identity (Name, [Either Type Type])
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens
      (Name, [Either Type (Maybe Name, Type)])
      (Name, [Either Type Type])
      [Either Type (Maybe Name, Type)]
      [Either Type Type]
    _2 (([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
     -> (Name, [Either Type (Maybe Name, Type)])
     -> Identity (Name, [Either Type Type]))
    -> (((Maybe Name, Type) -> Identity Type)
        -> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
    -> ((Maybe Name, Type) -> Identity Type)
    -> (Name, [Either Type (Maybe Name, Type)])
    -> Identity (Name, [Either Type Type])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Either Type (Maybe Name, Type) -> Identity (Either Type Type))
    -> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type]
    Setter
      [Either Type (Maybe Name, Type)]
      [Either Type Type]
      (Either Type (Maybe Name, Type))
      (Either Type Type)
    forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
    mapped ((Either Type (Maybe Name, Type) -> Identity (Either Type Type))
     -> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
    -> (((Maybe Name, Type) -> Identity Type)
        -> Either Type (Maybe Name, Type) -> Identity (Either Type Type))
    -> ((Maybe Name, Type) -> Identity Type)
    -> [Either Type (Maybe Name, Type)]
    -> Identity [Either Type Type]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Maybe Name, Type) -> Identity Type)
    -> Either Type (Maybe Name, Type) -> Identity (Either Type Type)
    forall c a b (p :: * -> * -> *) (f :: * -> *).
    (Choice p, Applicative f) =>
    p a (f b) -> p (Either c a) (f (Either c b))
    _Right (((Maybe Name, Type) -> Identity Type)
     -> (Name, [Either Type (Maybe Name, Type)])
     -> Identity (Name, [Either Type Type]))
    -> ((Maybe Name, Type) -> Type)
    -> (Name, [Either Type (Maybe Name, Type)])
    -> (Name, [Either Type Type])
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    %~ (Maybe Name, Type) -> Type
    forall a b. (a, b) -> b
    snd))

         let defType
               | Just ([TyVarBndrSpec]
    _,[Type]
    cx,Type
    a') <- Getting
      (First ([TyVarBndrSpec], [Type], Type))
      Type
      ([TyVarBndrSpec], [Type], Type)
    -> Type -> Maybe ([TyVarBndrSpec], [Type], Type)
    forall s (m :: * -> *) a.
    MonadReader s m =>
    Getting (First a) s a -> m (Maybe a)
    preview Getting
      (First ([TyVarBndrSpec], [Type], Type))
      Type
      ([TyVarBndrSpec], [Type], Type)
    Prism' Type ([TyVarBndrSpec], [Type], Type)
    _ForallT Type
    a =
                   let optic :: Name
    optic | Bool
    lensCase  = Name
    getterTypeName
                             | Bool
    otherwise = Name
    foldTypeName
                   in [Type] -> Name -> Type -> Type -> OpticStab
    OpticSa [Type]
    cx Name
    optic Type
    s' Type
    a'

               -- Getter and Fold are always simple
               | Bool -> Bool
    not (LensRules -> Bool
    _allowUpdates LensRules
    rules) =
                   let optic :: Name
    optic | Bool
    lensCase  = Name
    getterTypeName
                             | Bool
    otherwise = Name
    foldTypeName
                   in [Type] -> Name -> Type -> Type -> OpticStab
    OpticSa [] Name
    optic Type
    s' Type
    a

               -- Generate simple Lens and Traversal where possible
               | LensRules -> Bool
    _simpleLenses LensRules
    rules Bool -> Bool -> Bool
    || Type
    s' Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    t Bool -> Bool -> Bool
    && Type
    a Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    b =
                   let optic :: Name
    optic | Bool
    isoCase Bool -> Bool -> Bool
    && LensRules -> Bool
    _allowIsos LensRules
    rules = Name
    iso'TypeName
                             | Bool
    lensCase                    = Name
    lens'TypeName
                             | Bool
    otherwise                   = Name
    traversal'TypeName
                   in [Type] -> Name -> Type -> Type -> OpticStab
    OpticSa [] Name
    optic Type
    s' Type
    a

               -- Generate type-changing Lens and Traversal otherwise
               | Bool
    otherwise =
                   let optic :: Name
    optic | Bool
    isoCase Bool -> Bool -> Bool
    && LensRules -> Bool
    _allowIsos LensRules
    rules = Name
    isoTypeName
                             | Bool
    lensCase                    = Name
    lensTypeName
                             | Bool
    otherwise                   = Name
    traversalTypeName
                   in Name -> Type -> Type -> Type -> Type -> OpticStab
    OpticStab Name
    optic Type
    s' Type
    t Type
    a Type
    b

             opticType | Getting Any Type ([TyVarBndrSpec], [Type], Type) -> Type -> Bool
    forall s a. Getting Any s a -> s -> Bool
    has Getting Any Type ([TyVarBndrSpec], [Type], Type)
    Prism' Type ([TyVarBndrSpec], [Type], Type)
    _ForallT Type
    a            = OpticType
    GetterType
                       | Bool -> Bool
    not (LensRules -> Bool
    _allowUpdates LensRules
    rules) = OpticType
    GetterType
                       | Bool
    isoCase                   = OpticType
    IsoType
                       | Bool
    otherwise                 = OpticType
    LensType

         return (opticType, defType, scaffolds)
      where
      consForDef :: [(Name, [Either Type (Maybe Name, Type)])]
      consForDef :: [(Name, [Either Type (Maybe Name, Type)])]
    consForDef = ASetter
      [(Name, [([(DefName, Maybe Name)], Type)])]
      [(Name, [Either Type (Maybe Name, Type)])]
      ([(DefName, Maybe Name)], Type)
      (Either Type (Maybe Name, Type))
    -> (([(DefName, Maybe Name)], Type)
        -> Either Type (Maybe Name, Type))
    -> [(Name, [([(DefName, Maybe Name)], Type)])]
    -> [(Name, [Either Type (Maybe Name, Type)])]
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over (((Name, [([(DefName, Maybe Name)], Type)])
     -> Identity (Name, [Either Type (Maybe Name, Type)]))
    -> [(Name, [([(DefName, Maybe Name)], Type)])]
    -> Identity [(Name, [Either Type (Maybe Name, Type)])]
    Setter
      [(Name, [([(DefName, Maybe Name)], Type)])]
      [(Name, [Either Type (Maybe Name, Type)])]
      (Name, [([(DefName, Maybe Name)], Type)])
      (Name, [Either Type (Maybe Name, Type)])
    forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
    mapped (((Name, [([(DefName, Maybe Name)], Type)])
      -> Identity (Name, [Either Type (Maybe Name, Type)]))
     -> [(Name, [([(DefName, Maybe Name)], Type)])]
     -> Identity [(Name, [Either Type (Maybe Name, Type)])])
    -> ((([(DefName, Maybe Name)], Type)
         -> Identity (Either Type (Maybe Name, Type)))
        -> (Name, [([(DefName, Maybe Name)], Type)])
        -> Identity (Name, [Either Type (Maybe Name, Type)]))
    -> ASetter
         [(Name, [([(DefName, Maybe Name)], Type)])]
         [(Name, [Either Type (Maybe Name, Type)])]
         ([(DefName, Maybe Name)], Type)
         (Either Type (Maybe Name, Type))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([([(DefName, Maybe Name)], Type)]
     -> Identity [Either Type (Maybe Name, Type)])
    -> (Name, [([(DefName, Maybe Name)], Type)])
    -> Identity (Name, [Either Type (Maybe Name, Type)])
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens
      (Name, [([(DefName, Maybe Name)], Type)])
      (Name, [Either Type (Maybe Name, Type)])
      [([(DefName, Maybe Name)], Type)]
      [Either Type (Maybe Name, Type)]
    _2 (([([(DefName, Maybe Name)], Type)]
      -> Identity [Either Type (Maybe Name, Type)])
     -> (Name, [([(DefName, Maybe Name)], Type)])
     -> Identity (Name, [Either Type (Maybe Name, Type)]))
    -> ((([(DefName, Maybe Name)], Type)
         -> Identity (Either Type (Maybe Name, Type)))
        -> [([(DefName, Maybe Name)], Type)]
        -> Identity [Either Type (Maybe Name, Type)])
    -> (([(DefName, Maybe Name)], Type)
        -> Identity (Either Type (Maybe Name, Type)))
    -> (Name, [([(DefName, Maybe Name)], Type)])
    -> Identity (Name, [Either Type (Maybe Name, Type)])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (([(DefName, Maybe Name)], Type)
     -> Identity (Either Type (Maybe Name, Type)))
    -> [([(DefName, Maybe Name)], Type)]
    -> Identity [Either Type (Maybe Name, Type)]
    Setter
      [([(DefName, Maybe Name)], Type)]
      [Either Type (Maybe Name, Type)]
      ([(DefName, Maybe Name)], Type)
      (Either Type (Maybe Name, Type))
    forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
    mapped) ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
    categorize [(Name, [([(DefName, Maybe Name)], Type)])]
    cons

      scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
      scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
    scaffolds = [ (Name
    n, [Either Type (Maybe Name, Type)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Either Type (Maybe Name, Type)]
    ts, (\(Int
    a, Maybe Name
    b) -> (Maybe Name
    b, Int
    a)) ((Int, Maybe Name) -> (Maybe Name, Int))
    -> [(Int, Maybe Name)] -> [(Maybe Name, Int)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Either Type (Maybe Name, Type)]
    ts [Either Type (Maybe Name, Type)]
    -> IndexedGetting
         Int
         (Endo [(Int, Maybe Name)])
         [Either Type (Maybe Name, Type)]
         (Maybe Name)
    -> [(Int, Maybe Name)]
    forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
    ^@.. Indexed
      Int
      (Either Type (Maybe Name, Type))
      (Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
    -> [Either Type (Maybe Name, Type)]
    -> Const
         (Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)]
    forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
    IndexedFold
      Int
      [Either Type (Maybe Name, Type)]
      (Either Type (Maybe Name, Type))
    folded (Indexed
       Int
       (Either Type (Maybe Name, Type))
       (Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
     -> [Either Type (Maybe Name, Type)]
     -> Const
          (Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)])
    -> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
        -> Either Type (Maybe Name, Type)
        -> Const
             (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
    -> IndexedGetting
         Int
         (Endo [(Int, Maybe Name)])
         [Either Type (Maybe Name, Type)]
         (Maybe Name)
    forall i (p :: * -> * -> *) s t r a b.
    Indexable i p =>
    (Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
    <. ((Maybe Name, Type)
     -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
    -> Either Type (Maybe Name, Type)
    -> Const
         (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
    forall c a b (p :: * -> * -> *) (f :: * -> *).
    (Choice p, Applicative f) =>
    p a (f b) -> p (Either c a) (f (Either c b))
    _Right (((Maybe Name, Type)
      -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
     -> Either Type (Maybe Name, Type)
     -> Const
          (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
    -> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
        -> (Maybe Name, Type)
        -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
    -> (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
    -> Either Type (Maybe Name, Type)
    -> Const
         (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
    -> (Maybe Name, Type)
    -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type)
    forall s t a b. Field1 s t a b => Lens s t a b
    Lens
      (Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
    _1) | (Name
    n,[Either Type (Maybe Name, Type)]
    ts) <- [(Name, [Either Type (Maybe Name, Type)])]
    consForDef ]

      -- Right: types for this definition
      -- Left : other types
      categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
      categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
    categorize ([(DefName, Maybe Name)]
    defNames, Type
    t) =
        case DefName -> [(DefName, Maybe Name)] -> Maybe (Maybe Name)
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup DefName
    defName [(DefName, Maybe Name)]
    defNames of
        Just Maybe Name
    c -> (Maybe Name, Type) -> Either Type (Maybe Name, Type)
    forall a b. b -> Either a b
    Right (Maybe Name
    c, Type
    t)
        Maybe (Maybe Name)
    Nothing -> Type -> Either Type (Maybe Name, Type)
    forall a b. a -> Either a b
    Left Type
    t

      lensCase :: Bool
      lensCase :: Bool
    lensCase = ((Name, [Either Type (Maybe Name, Type)]) -> Bool)
    -> [(Name, [Either Type (Maybe Name, Type)])] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (\(Name, [Either Type (Maybe Name, Type)])
    x -> Getting
      (Endo (Endo Int))
      (Name, [Either Type (Maybe Name, Type)])
      (Maybe Name, Type)
    -> (Name, [Either Type (Maybe Name, Type)]) -> Int
    forall s a. Getting (Endo (Endo Int)) s a -> s -> Int
    lengthOf (([Either Type (Maybe Name, Type)]
     -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
    -> (Name, [Either Type (Maybe Name, Type)])
    -> Const (Endo (Endo Int)) (Name, [Either Type (Maybe Name, Type)])
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens
      (Name, [Either Type (Maybe Name, Type)])
      (Name, [Either Type (Maybe Name, Type)])
      [Either Type (Maybe Name, Type)]
      [Either Type (Maybe Name, Type)]
    _2 (([Either Type (Maybe Name, Type)]
      -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
     -> (Name, [Either Type (Maybe Name, Type)])
     -> Const
          (Endo (Endo Int)) (Name, [Either Type (Maybe Name, Type)]))
    -> (((Maybe Name, Type)
         -> Const (Endo (Endo Int)) (Maybe Name, Type))
        -> [Either Type (Maybe Name, Type)]
        -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
    -> Getting
         (Endo (Endo Int))
         (Name, [Either Type (Maybe Name, Type)])
         (Maybe Name, Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Either Type (Maybe Name, Type)
     -> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
    -> [Either Type (Maybe Name, Type)]
    -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)]
    forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
    IndexedFold
      Int
      [Either Type (Maybe Name, Type)]
      (Either Type (Maybe Name, Type))
    folded ((Either Type (Maybe Name, Type)
      -> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
     -> [Either Type (Maybe Name, Type)]
     -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
    -> (((Maybe Name, Type)
         -> Const (Endo (Endo Int)) (Maybe Name, Type))
        -> Either Type (Maybe Name, Type)
        -> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
    -> ((Maybe Name, Type)
        -> Const (Endo (Endo Int)) (Maybe Name, Type))
    -> [Either Type (Maybe Name, Type)]
    -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Maybe Name, Type) -> Const (Endo (Endo Int)) (Maybe Name, Type))
    -> Either Type (Maybe Name, Type)
    -> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type))
    forall c a b (p :: * -> * -> *) (f :: * -> *).
    (Choice p, Applicative f) =>
    p a (f b) -> p (Either c a) (f (Either c b))
    _Right) (Name, [Either Type (Maybe Name, Type)])
    x Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1) [(Name, [Either Type (Maybe Name, Type)])]
    consForDef

      isoCase :: Bool
      isoCase :: Bool
    isoCase = case [(Name, Int, [(Maybe Name, Int)])]
    scaffolds of
                  [(Name
    _,Int
    1,[(Maybe Name
    _, Int
    0)])] -> Bool
    True
                  [(Name, Int, [(Maybe Name, Int)])]
    _                -> Bool
    False

    data OpticStab = OpticStab     Name Type Type Type Type
                   | OpticSa   Cxt Name Type Type

    stabToType :: OpticStab -> Type
    stabToType :: OpticStab -> Type
    stabToType (OpticStab  Name
    c Type
    s Type
    t Type
    a Type
    b) = [Type] -> Type -> Type
    quantifyType [] (Name
    c Name -> [Type] -> Type
    `conAppsT` [Type
    s,Type
    t,Type
    a,Type
    b])
    stabToType (OpticSa [Type]
    cx Name
    c Type
    s   Type
    a  ) = [Type] -> Type -> Type
    quantifyType [Type]
    cx (Name
    c Name -> [Type] -> Type
    `conAppsT` [Type
    s,Type
    a])

    stabToContext :: OpticStab -> Cxt
    stabToContext :: OpticStab -> [Type]
    stabToContext OpticStab{}        = []
    stabToContext (OpticSa [Type]
    cx Name
    _ Type
    _ Type
    _) = [Type]
    cx

    stabToOptic :: OpticStab -> Name
    stabToOptic :: OpticStab -> Name
    stabToOptic (OpticStab Name
    c Type
    _ Type
    _ Type
    _ Type
    _) = Name
    c
    stabToOptic (OpticSa [Type]
    _ Name
    c Type
    _ Type
    _) = Name
    c

    stabToS :: OpticStab -> Type
    stabToS :: OpticStab -> Type
    stabToS (OpticStab Name
    _ Type
    s Type
    _ Type
    _ Type
    _) = Type
    s
    stabToS (OpticSa [Type]
    _ Name
    _ Type
    s Type
    _) = Type
    s

    stabToA :: OpticStab -> Type
    stabToA :: OpticStab -> Type
    stabToA (OpticStab Name
    _ Type
    _ Type
    _ Type
    a Type
    _) = Type
    a
    stabToA (OpticSa [Type]
    _ Name
    _ Type
    _ Type
    a) = Type
    a

    -- | Compute the s t a b types given the outer type 's' and the
    -- categorized field types. Left for fixed and Right for visited.
    -- These types are "raw" and will be packaged into an 'OpticStab'
    -- shortly after creation.
    buildStab :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type)
    buildStab :: Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
    buildStab Type
    s [Either Type Type]
    categorizedFields =
      do (subA,a) <- [Type] -> Q (Map Name Type, Type)
    unifyTypes [Type]
    targetFields
         let s' = Map Name Type -> Type -> Type
    applyTypeSubst Map Name Type
    subA Type
    s

         -- compute possible type changes
         sub <- T.sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars)
         let (t,b) = over both (substTypeVars sub) (s',a)

         return (s',t,a,b)

      where
      ([Type]
    fixedFields, [Type]
    targetFields) = [Either Type Type] -> ([Type], [Type])
    forall a b. [Either a b] -> ([a], [b])
    partitionEithers [Either Type Type]
    categorizedFields

      fixedTypeVars, unfixedTypeVars :: Set Name
      fixedTypeVars :: Set Name
    fixedTypeVars   = Set Name -> Set Name
    closeOverKinds (Set Name -> Set Name) -> Set Name -> Set Name
    forall a b. (a -> b) -> a -> b
    $ Getting (Set Name) [Type] Name -> [Type] -> Set Name
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf Getting (Set Name) [Type] Name
    forall t. HasTypeVars t => Traversal' t Name
    Traversal' [Type] Name
    typeVars [Type]
    fixedFields
      unfixedTypeVars :: Set Name
    unfixedTypeVars = Getting (Set Name) Type Name -> Type -> Set Name
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf Getting (Set Name) Type Name
    forall t. HasTypeVars t => Traversal' t Name
    Traversal' Type Name
    typeVars Type
    s Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.\\ Set Name
    fixedTypeVars

      -- Compute the kind variables that appear in the kind of a type variable
      -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a
      -- type variable binder lacks an explicit kind annotation, this
      -- conservatively assumes that there are no kind variables. For example,
      -- @kindVarsOfTvb (y) = (y, {})@.
      kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name)
      kindVarsOfTvb :: forall flag. TyVarBndr_ flag -> (Name, Set Name)
    kindVarsOfTvb = (Name -> (Name, Set Name))
    -> (Name -> Type -> (Name, Set Name))
    -> TyVarBndr_ flag
    -> (Name, Set Name)
    forall r flag.
    (Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
    D.elimTV (\Name
    n   -> (Name
    n, Set Name
    forall a. Set a
    Set.empty))
                               (\Name
    n Type
    k -> (Name
    n, Getting (Set Name) Type Name -> Type -> Set Name
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf Getting (Set Name) Type Name
    forall t. HasTypeVars t => Traversal' t Name
    Traversal' Type Name
    typeVars Type
    k))

      -- For each type variable name that appears in @s@, map to the kind variables
      -- that appear in that type variable's kind.
      sKindVarMap :: Map Name (Set Name)
      sKindVarMap :: Map Name (Set Name)
    sKindVarMap = [(Name, Set Name)] -> Map Name (Set Name)
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(Name, Set Name)] -> Map Name (Set Name))
    -> [(Name, Set Name)] -> Map Name (Set Name)
    forall a b. (a -> b) -> a -> b
    $ (TyVarBndr_ () -> (Name, Set Name))
    -> [TyVarBndr_ ()] -> [(Name, Set Name)]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr_ () -> (Name, Set Name)
    forall flag. TyVarBndr_ flag -> (Name, Set Name)
    kindVarsOfTvb ([TyVarBndr_ ()] -> [(Name, Set Name)])
    -> [TyVarBndr_ ()] -> [(Name, Set Name)]
    forall a b. (a -> b) -> a -> b
    $ [Type] -> [TyVarBndr_ ()]
    D.freeVariablesWellScoped [Type
    s]

      lookupSKindVars :: Name -> Set Name
      lookupSKindVars :: Name -> Set Name
    lookupSKindVars Name
    n = Set Name -> Maybe (Set Name) -> Set Name
    forall a. a -> Maybe a -> a
    fromMaybe Set Name
    forall a. Set a
    Set.empty (Maybe (Set Name) -> Set Name) -> Maybe (Set Name) -> Set Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Map Name (Set Name) -> Maybe (Set Name)
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    n Map Name (Set Name)
    sKindVarMap

      -- Consider this example (adapted from #972):
      --
      --   data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int }
      --   $(makeLenses ''Dart)
      --
      -- When generating a Lens for `direction`, the type variable `s` should be
      -- fixed. But note that (s :: k), and as a result, the kind variable `k`
      -- needs to be fixed as well. This is because a type like this would be
      -- ill kinded:
      --
      --   direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction
      --
      -- However, only `s` is mentioned syntactically in the type of `_arc`, so we
      -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this
      -- with `closeOverKinds`, which does the following:
      --
      -- 1. Use freeVariablesWellScoped to compute the free type variables of
      --    `Dart (s :: k)`, which gives us `(s :: k)`.
      -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up
      --    the kind variables in the type variable's kind. In the case of `s`,
      --    the only kind variable is `k`.
      -- 3. Add these kind variables to the set of fixed type variables.
      closeOverKinds :: Set Name -> Set Name
      closeOverKinds :: Set Name -> Set Name
    closeOverKinds Set Name
    st = (Set Name -> Set Name -> Set Name)
    -> Set Name -> Set (Set Name) -> Set Name
    forall b a. (b -> a -> b) -> b -> Set a -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.union Set Name
    forall a. Set a
    Set.empty ((Name -> Set Name) -> Set Name -> Set (Set Name)
    forall b a. Ord b => (a -> b) -> Set a -> Set b
    Set.map Name -> Set Name
    lookupSKindVars Set Name
    st) Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    `Set.union` Set Name
    st

    -- | Build the signature and definition for a single field optic.
    -- In the case of a singleton constructor irrefutable matches are
    -- used to enable the resulting lenses to be used on a bottom value.
    makeFieldOptic ::
      LensRules ->
      (DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])) ->
      HasFieldClasses [Dec]
    makeFieldOptic :: LensRules
    -> (DefName,
        (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> StateT (Set Name) Q [Dec]
    makeFieldOptic LensRules
    rules (DefName
    defName, (OpticType
    opticType, OpticStab
    defType, [(Name, Int, [(Maybe Name, Int)])]
    cons)) = do
      locals <- StateT (Set Name) Q (Set Name)
    forall s (m :: * -> *). MonadState s m => m s
    get
      addName
      lift $ do cls <- mkCls locals
                T.sequenceA (cls ++ sig ++ def)
      where
      mkCls :: Set Name -> Q [DecQ]
    mkCls Set Name
    locals = case DefName
    defName of
                     MethodName Name
    c Name
    n | LensRules -> Bool
    _generateClasses LensRules
    rules ->
                      do classExists <- Maybe Name -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe Name -> Bool) -> Q (Maybe Name) -> Q Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q (Maybe Name)
    lookupTypeName (Name -> String
    forall a. Show a => a -> String
    show Name
    c)
                         return (if classExists || Set.member c locals then [] else [makeFieldClass defType c n])
                     DefName
    _ -> [DecQ] -> Q [DecQ]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

      addName :: HasFieldClasses ()
    addName = case DefName
    defName of
                MethodName Name
    c Name
    _ -> Name -> HasFieldClasses ()
    addFieldClassName Name
    c
                DefName
    _              -> () -> HasFieldClasses ()
    forall a. a -> StateT (Set Name) Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

      sig :: [DecQ]
    sig = case DefName
    defName of
              DefName
    _ | Bool -> Bool
    not (LensRules -> Bool
    _generateSigs LensRules
    rules) -> []
              TopName Name
    n -> [Name -> Q Type -> DecQ
    forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
    sigD Name
    n (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (OpticStab -> Type
    stabToType OpticStab
    defType))]
              MethodName{} -> []

      fun :: Name -> [DecQ]
    fun Name
    n = Name -> [Q Clause] -> DecQ
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD Name
    n [Q Clause]
    clauses DecQ -> [DecQ] -> [DecQ]
    forall a. a -> [a] -> [a]
    : Name -> [DecQ]
    inlinePragma Name
    n

      def :: [DecQ]
    def = case DefName
    defName of
              TopName Name
    n      -> Name -> [DecQ]
    fun Name
    n
              MethodName Name
    c Name
    n -> [OpticStab -> Name -> [DecQ] -> DecQ
    makeFieldInstance OpticStab
    defType Name
    c (Name -> [DecQ]
    fun Name
    n)]

      clauses :: [Q Clause]
    clauses = LensRules
    -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [Q Clause]
    makeFieldClauses LensRules
    rules OpticType
    opticType [(Name, Int, [(Maybe Name, Int)])]
    cons

    ------------------------------------------------------------------------
    -- Classy class generator
    ------------------------------------------------------------------------

    makeClassyDriver ::
      LensRules ->
      Name ->
      Name ->
      Type {- ^ Outer 's' type -} ->
      [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
      HasFieldClasses [Dec]
    makeClassyDriver :: LensRules
    -> Name
    -> Name
    -> Type
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> StateT (Set Name) Q [Dec]
    makeClassyDriver LensRules
    rules Name
    className Name
    methodName Type
    s [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs = [StateT (Set Name) Q Dec] -> StateT (Set Name) Q [Dec]
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
    T.sequenceA ([StateT (Set Name) Q Dec]
    cls [StateT (Set Name) Q Dec]
    -> [StateT (Set Name) Q Dec] -> [StateT (Set Name) Q Dec]
    forall a. [a] -> [a] -> [a]
    ++ [StateT (Set Name) Q Dec]
    inst)

      where
      cls :: [StateT (Set Name) Q Dec]
    cls | LensRules -> Bool
    _generateClasses LensRules
    rules = [DecQ -> StateT (Set Name) Q Dec
    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 (DecQ -> StateT (Set Name) Q Dec)
    -> DecQ -> StateT (Set Name) Q Dec
    forall a b. (a -> b) -> a -> b
    $ Name
    -> Name
    -> Type
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> DecQ
    makeClassyClass Name
    className Name
    methodName Type
    s [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs]
          | Bool
    otherwise = []

      inst :: [StateT (Set Name) Q Dec]
    inst = [LensRules
    -> Name
    -> Name
    -> Type
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> StateT (Set Name) Q Dec
    makeClassyInstance LensRules
    rules Name
    className Name
    methodName Type
    s [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs]

    makeClassyClass ::
      Name ->
      Name ->
      Type {- ^ Outer 's' type -} ->
      [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
      DecQ
    makeClassyClass :: Name
    -> Name
    -> Type
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> DecQ
    makeClassyClass Name
    className Name
    methodName Type
    s [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs = do
      let ss :: [Type]
    ss   = ((DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     -> Type)
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (OpticStab -> Type
    stabToS (OpticStab -> Type)
    -> ((DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
        -> OpticStab)
    -> (DefName,
        (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Getting
      OpticStab
      (DefName,
       (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
      OpticStab
    -> (DefName,
        (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> OpticStab
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
     -> Const
          OpticStab
          (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> (DefName,
        (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> Const
         OpticStab
         (DefName,
          (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens
      (DefName,
       (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
      (DefName,
       (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    _2 (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
      -> Const
           OpticStab
           (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     -> (DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     -> Const
          OpticStab
          (DefName,
           (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
    -> ((OpticStab -> Const OpticStab OpticStab)
        -> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
        -> Const
             OpticStab
             (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> Getting
         OpticStab
         (DefName,
          (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
         OpticStab
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (OpticStab -> Const OpticStab OpticStab)
    -> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    -> Const
         OpticStab
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
      OpticStab
      OpticStab
    _2)) [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs
      (sub,s') <- [Type] -> Q (Map Name Type, Type)
    unifyTypes (Type
    s Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : [Type]
    ss)
      c <- newName "c"
      let vars     = BndrVis -> [TyVarBndr_ ()] -> [TyVarBndr_ BndrVis]
    forall newFlag oldFlag.
    newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
    D.changeTVFlags BndrVis
    bndrReq ([TyVarBndr_ ()] -> [TyVarBndr_ BndrVis])
    -> [TyVarBndr_ ()] -> [TyVarBndr_ BndrVis]
    forall a b. (a -> b) -> a -> b
    $ [Type] -> [TyVarBndr_ ()]
    D.freeVariablesWellScoped [Type
    s']
          varNames = (TyVarBndr_ BndrVis -> Name) -> [TyVarBndr_ BndrVis] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr_ BndrVis -> Name
    forall flag. TyVarBndr_ flag -> Name
    D.tvName [TyVarBndr_ BndrVis]
    vars
          fd   | [TyVarBndr_ BndrVis] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVarBndr_ BndrVis]
    vars = []
               | Bool
    otherwise = [[Name] -> [Name] -> FunDep
    FunDep [Name
    c] [Name]
    varNames]

      classD (cxt[]) className (D.plainTV c:vars) fd
        $ sigD methodName (return (lens'TypeName `conAppsT` [VarT c, s']))
        : concat
          [ [sigD defName (return ty)
            ,valD (varP defName) (normalB body) []
            ] ++
            inlinePragma defName
          | (TopName defName, (_, stab, _)) <- defs
          , let 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
    composeValName, Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    methodName, Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    defName]
          , let ty   = Set Name -> [Type] -> Type -> Type
    quantifyType' ([Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    Set.fromList (Name
    cName -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    :[Name]
    varNames))
                                     (OpticStab -> [Type]
    stabToContext OpticStab
    stab)
                     (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ OpticStab -> Name
    stabToOptic OpticStab
    stab Name -> [Type] -> Type
    `conAppsT`
                           [Name -> Type
    VarT Name
    c, Map Name Type -> Type -> Type
    applyTypeSubst Map Name Type
    sub (OpticStab -> Type
    stabToA OpticStab
    stab)]
          ]

    makeClassyInstance ::
      LensRules ->
      Name ->
      Name ->
      Type {- ^ Outer 's' type -} ->
      [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
      HasFieldClasses Dec
    makeClassyInstance :: LensRules
    -> Name
    -> Name
    -> Type
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> StateT (Set Name) Q Dec
    makeClassyInstance LensRules
    rules Name
    className Name
    methodName Type
    s [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs = do
      methodss <- ((DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     -> StateT (Set Name) Q [Dec])
    -> [(DefName,
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    -> StateT (Set Name) Q [[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 (LensRules
    -> (DefName,
        (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> StateT (Set Name) Q [Dec]
    makeFieldOptic LensRules
    rules') [(DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
    defs

      lift $ instanceD (cxt[]) (return instanceHead)
               $ valD (varP methodName) (normalB (varE idValName)) []
               : map return (concat methodss)

      where
      instanceHead :: Type
    instanceHead = Name
    className Name -> [Type] -> Type
    `conAppsT` (Type
    s Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : (TyVarBndr_ () -> Type) -> [TyVarBndr_ ()] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr_ () -> Type
    forall flag. TyVarBndr_ flag -> Type
    tvbToType [TyVarBndr_ ()]
    vars)
      vars :: [TyVarBndr_ ()]
    vars         = [Type] -> [TyVarBndr_ ()]
    D.freeVariablesWellScoped [Type
    s]
      rules' :: LensRules
    rules'       = LensRules
    rules { _generateSigs    = False
                           , _generateClasses = False
                           }

    ------------------------------------------------------------------------
    -- Field class generation
    ------------------------------------------------------------------------

    makeFieldClass :: OpticStab -> Name -> Name -> DecQ
    makeFieldClass :: OpticStab -> Name -> Name -> DecQ
    makeFieldClass OpticStab
    defType Name
    className Name
    methodName =
      Q [Type]
    -> Name -> [TyVarBndr_ BndrVis] -> [FunDep] -> [DecQ] -> DecQ
    forall (m :: * -> *).
    Quote m =>
    m [Type]
    -> Name -> [TyVarBndr_ BndrVis] -> [FunDep] -> [m Dec] -> m Dec
    classD ([Q Type] -> Q [Type]
    forall (m :: * -> *). Quote m => [m Type] -> m [Type]
    cxt []) Name
    className [Name -> TyVarBndr_ BndrVis
    forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
    D.plainTV Name
    s, Name -> TyVarBndr_ BndrVis
    forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
    D.plainTV Name
    a] [[Name] -> [Name] -> FunDep
    FunDep [Name
    s] [Name
    a]]
             [Name -> Q Type -> DecQ
    forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
    sigD Name
    methodName (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    methodType)]
      where
      methodType :: Type
    methodType = Set Name -> [Type] -> Type -> Type
    quantifyType' ([Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    Set.fromList [Name
    s,Name
    a])
                                 (OpticStab -> [Type]
    stabToContext OpticStab
    defType)
                 (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ OpticStab -> Name
    stabToOptic OpticStab
    defType Name -> [Type] -> Type
    `conAppsT` [Name -> Type
    VarT Name
    s,Name -> Type
    VarT Name
    a]
      s :: Name
    s = String -> Name
    mkName String
    "s"
      a :: Name
    a = String -> Name
    mkName String
    "a"

    -- | Build an instance for a field. If the field’s type contains any type
    -- families, will produce an equality constraint to avoid a type family
    -- application in the instance head.
    makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
    makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
    makeFieldInstance OpticStab
    defType Name
    className [DecQ]
    decs =
      Type -> Q Bool
    containsTypeFamilies Type
    a Q Bool -> (Bool -> DecQ) -> DecQ
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Bool -> DecQ
    pickInstanceDec
      where
      s :: Type
    s = OpticStab -> Type
    stabToS OpticStab
    defType
      a :: Type
    a = OpticStab -> Type
    stabToA OpticStab
    defType

      containsTypeFamilies :: Type -> Q Bool
    containsTypeFamilies = Type -> Q Bool
    go (Type -> Q Bool) -> (Type -> Q Type) -> Type -> Q Bool
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< Type -> Q Type
    D.resolveTypeSynonyms
        where
        go :: Type -> Q Bool
        go :: Type -> Q Bool
    go (ConT Name
    nm) =
          -- Note that the call to `reify` can fail if `nm` is not yet defined.
          -- (This can actually happen if `nm` is declared in a Template Haskell
          -- quote.) If this fails, there is no way to tell if the type contains
          -- type families, so we recover and conservatively assume that is does not
          -- contain any.
          Q Bool -> Q Bool -> Q Bool
    forall a. Q a -> Q a -> Q a
    recover
            (Bool -> Q Bool
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Bool
    False)
            (Getting Any Info () -> Info -> Bool
    forall s a. Getting Any s a -> s -> Bool
    has (((Dec, [Dec]) -> Const Any (Dec, [Dec])) -> Info -> Const Any Info
    Prism' Info (Dec, [Dec])
    _FamilyI (((Dec, [Dec]) -> Const Any (Dec, [Dec]))
     -> Info -> Const Any Info)
    -> ((() -> Const Any ()) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
    -> Getting Any Info ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec])
    forall s t a b. Field1 s t a b => Lens s t a b
    Lens (Dec, [Dec]) (Dec, [Dec]) Dec Dec
    _1 ((Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
    -> Getting Any Dec ()
    -> (() -> Const Any ())
    -> (Dec, [Dec])
    -> Const Any (Dec, [Dec])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Getting Any Dec ()
    _TypeFamilyD) (Info -> Bool) -> Q Info -> Q Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> Q Info
    reify Name
    nm)
        go Type
    ty = [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Type -> Q Bool) -> [Type] -> Q [Bool]
    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 Type -> Q Bool
    go (Type
    ty Type -> Getting (Endo [Type]) Type Type -> [Type]
    forall s a. s -> Getting (Endo [a]) s a -> [a]
    ^.. Getting (Endo [Type]) Type Type
    forall a. Plated a => Traversal' a a
    Traversal' Type Type
    plate)

        -- We want to catch type families, but not *data* families. See #799.
        _TypeFamilyD :: Getting Any Dec ()
        _TypeFamilyD :: Getting Any Dec ()
    _TypeFamilyD = (TypeFamilyHead -> Const Any TypeFamilyHead)
    -> Dec -> Const Any Dec
    Prism' Dec TypeFamilyHead
    _OpenTypeFamilyD((TypeFamilyHead -> Const Any TypeFamilyHead)
     -> Dec -> Const Any Dec)
    -> ((() -> Const Any ())
        -> TypeFamilyHead -> Const Any TypeFamilyHead)
    -> Getting Any Dec ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .(() -> Const Any ()) -> TypeFamilyHead -> Const Any TypeFamilyHead
    forall a (f :: * -> *). Functor f => (() -> f ()) -> a -> f a
    united Getting Any Dec () -> Getting Any Dec () -> Getting Any Dec ()
    forall a. Semigroup a => a -> a -> a
    <> ((TypeFamilyHead, [TySynEqn])
     -> Const Any (TypeFamilyHead, [TySynEqn]))
    -> Dec -> Const Any Dec
    Prism' Dec (TypeFamilyHead, [TySynEqn])
    _ClosedTypeFamilyD(((TypeFamilyHead, [TySynEqn])
      -> Const Any (TypeFamilyHead, [TySynEqn]))
     -> Dec -> Const Any Dec)
    -> ((() -> Const Any ())
        -> (TypeFamilyHead, [TySynEqn])
        -> Const Any (TypeFamilyHead, [TySynEqn]))
    -> Getting Any Dec ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .(() -> Const Any ())
    -> (TypeFamilyHead, [TySynEqn])
    -> Const Any (TypeFamilyHead, [TySynEqn])
    forall a (f :: * -> *). Functor f => (() -> f ()) -> a -> f a
    united

      pickInstanceDec :: Bool -> DecQ
    pickInstanceDec Bool
    hasFamilies
        | Bool
    hasFamilies = do
            placeholder <- Name -> Type
    VarT (Name -> Type) -> Q Name -> 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
    "a"
            mkInstanceDec
              [return (D.equalPred placeholder a)]
              [s, placeholder]
        | Bool
    otherwise = [Q Type] -> [Type] -> DecQ
    mkInstanceDec [] [Type
    s, Type
    a]

      mkInstanceDec :: [Q Type] -> [Type] -> DecQ
    mkInstanceDec [Q Type]
    context [Type]
    headTys =
        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]
    context) (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name
    className Name -> [Type] -> Type
    `conAppsT` [Type]
    headTys)) [DecQ]
    decs

    ------------------------------------------------------------------------
    -- Optic clause generators
    ------------------------------------------------------------------------

    makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ]
    makeFieldClauses :: LensRules
    -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [Q Clause]
    makeFieldClauses LensRules
    rules OpticType
    opticType [(Name, Int, [(Maybe Name, Int)])]
    cons =
      case OpticType
    opticType of

        OpticType
    IsoType    -> [ Name -> Q Clause
    makeIsoClause Name
    conName | (Name
    conName, Int
    _, [(Maybe Name, Int)]
    _) <- [(Name, Int, [(Maybe Name, Int)])]
    cons ]

        OpticType
    GetterType -> [ Name -> Int -> [Int] -> Q Clause
    makeGetterClause Name
    conName Int
    fieldCount ((Maybe Name, Int) -> Int
    forall a b. (a, b) -> b
    snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [(Maybe Name, Int)]
    fields)
                        | (Name
    conName, Int
    fieldCount, [(Maybe Name, Int)]
    fields) <- [(Name, Int, [(Maybe Name, Int)])]
    cons ]

        OpticType
    LensType   -> [ Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> Q Clause
    makeFieldOpticClause Name
    conName Int
    fieldCount [(Maybe Name, Int)]
    fields Bool
    irref Bool
    recSyn
                        | (Name
    conName, Int
    fieldCount, [(Maybe Name, Int)]
    fields) <- [(Name, Int, [(Maybe Name, Int)])]
    cons ]
          where
          irref :: Bool
    irref = LensRules -> Bool
    _lazyPatterns LensRules
    rules
               Bool -> Bool -> Bool
    && [(Name, Int, [(Maybe Name, Int)])] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Name, Int, [(Maybe Name, Int)])]
    cons Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1
          recSyn :: Bool
    recSyn = LensRules -> Bool
    _recordSyntax LensRules
    rules Bool -> Bool -> Bool
    && [(Name, Int, [(Maybe Name, Int)])] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Name, Int, [(Maybe Name, Int)])]
    cons Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1

    -- | Construct an optic clause that returns an unmodified value
    -- given a constructor name and the number of fields on that
    -- constructor.
    makePureClause :: Name -> Int -> ClauseQ
    makePureClause :: Name -> Int -> Q Clause
    makePureClause Name
    conName Int
    fieldCount =
      do xs <- String -> Int -> Q [Name]
    newNames String
    "x" Int
    fieldCount
         -- clause: _ (Con x1..xn) = pure (Con x1..xn)
         clause [wildP, conP conName (map varP xs)]
                (normalB (appE (varE pureValName) (appsE (conE conName : map varE xs))))
                []

    -- | Construct an optic clause suitable for a Getter or Fold
    -- by visited the fields identified by their 0 indexed positions
    makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
    makeGetterClause :: Name -> Int -> [Int] -> Q Clause
    makeGetterClause Name
    conName Int
    fieldCount []     = Name -> Int -> Q Clause
    makePureClause Name
    conName Int
    fieldCount
    makeGetterClause Name
    conName Int
    fieldCount [Int]
    fields =
      do f  <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "f"
         xs <- newNames "x" (length fields)
         xs' <-
           case xs of
             (Name
    x:[Name]
    xs') -> NonEmpty Name -> Q (NonEmpty Name)
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Name
    x Name -> [Name] -> NonEmpty Name
    forall a. a -> [a] -> NonEmpty a
    :| [Name]
    xs')
             []      -> String -> Q (NonEmpty Name)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "makeGetterClause: Internal check failed"

         let pats (Int
    i:[Int]
    is) (Name
    y:[Name]
    ys)
               | Int
    i Int -> [Int] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Int]
    fields = Name -> m Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    y m Pat -> [m Pat] -> [m Pat]
    forall a. a -> [a] -> [a]
    : [Int] -> [Name] -> [m Pat]
    pats [Int]
    is [Name]
    ys
               | Bool
    otherwise = m Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP m Pat -> [m Pat] -> [m Pat]
    forall a. a -> [a] -> [a]
    : [Int] -> [Name] -> [m Pat]
    pats [Int]
    is (Name
    yName -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    :[Name]
    ys)
             pats [Int]
    is     [Name]
    _  = (Int -> m Pat) -> [Int] -> [m Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map (m Pat -> Int -> m Pat
    forall a b. a -> b -> a
    const m Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP) [Int]
    is

             (fx :| fxs) = fmap (appE (varE f) . varE) xs'
             body  = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\Q Exp
    a Q Exp
    b -> [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
    apValName, Q Exp
    a, Q Exp
    b])
                           (Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    phantomValName) Q Exp
    fx)
                           [Q Exp]
    fxs

         -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn
         clause [varP f, conP conName (pats [0..fieldCount - 1] xs)]
                (normalB body)
                []

    -- | Build a clause that updates the field at the given indexes
    -- When irref is 'True' the value with me matched with an irrefutable
    -- pattern. This is suitable for Lens and Traversal construction
    makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ
    makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> Q Clause
    makeFieldOpticClause Name
    conName Int
    fieldCount [] Bool
    _ Bool
    _ =
      Name -> Int -> Q Clause
    makePureClause Name
    conName Int
    fieldCount
    makeFieldOpticClause Name
    _ Int
    _ [(Just Name
    fieldName, Int
    _)] Bool
    _ Bool
    True =
      do f <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "f"
         r <- newName "r"
         x <- newName "x"
         let body = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE [ [| fmap |]
                          , [Q Pat] -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
    lamE [Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    x] (Q Exp -> [Q (Name, Exp)] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
    recUpdE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    r) [(,) Name
    fieldName (Exp -> (Name, Exp)) -> Q Exp -> Q (Name, Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    x])
                          , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    f Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    fieldName Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    r)
                          ]
         clause [varP f, varP r] (normalB body) []
    makeFieldOpticClause Name
    conName Int
    fieldCount ((Maybe Name
    _, Int
    field):[(Maybe Name, Int)]
    fieldsWithNames) Bool
    irref Bool
    _ =
      do f  <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "f"
         xs <- newNames "x" fieldCount
         ys <- newNames "y" (1 + length fieldsWithNames)

         let fields = (Maybe Name, Int) -> Int
    forall a b. (a, b) -> b
    snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [(Maybe Name, Int)]
    fieldsWithNames
             xs' = ((Int, Name) -> [Name] -> [Name])
    -> [Name] -> [(Int, Name)] -> [Name]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\(Int
    i,Name
    x) -> ASetter [Name] [Name] Name Name -> Name -> [Name] -> [Name]
    forall s t a b. ASetter s t a b -> b -> s -> t
    set (Index [Name] -> Traversal' [Name] (IxValue [Name])
    forall m. Ixed m => Index m -> Traversal' m (IxValue m)
    ix Int
    Index [Name]
    i) Name
    x) [Name]
    xs ([Int] -> [Name] -> [(Int, Name)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Int
    fieldInt -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    :[Int]
    fields) [Name]
    ys)

             mkFx Int
    i = m Exp -> m Exp -> m Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    f) (Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE ([Name]
    xs [Name] -> Int -> Name
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    i))

             body0 = [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
    fmapValName
                           , [Q Pat] -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
    lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP [Name]
    ys) ([Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conName Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    : (Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE [Name]
    xs'))
                           , Int -> Q Exp
    forall {m :: * -> *}. Quote m => Int -> m Exp
    mkFx Int
    field
                           ]

             body = (Q Exp -> Int -> Q Exp) -> Q Exp -> [Int] -> Q Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\Q Exp
    a Int
    b -> [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
    apValName, Q Exp
    a, Int -> Q Exp
    forall {m :: * -> *}. Quote m => Int -> m Exp
    mkFx Int
    b]) Q Exp
    body0 [Int]
    fields

         let wrap = if Bool
    irref then Q Pat -> Q Pat
    forall (m :: * -> *). Quote m => m Pat -> m Pat
    tildeP else Q Pat -> Q Pat
    forall a. a -> a
    id

         clause [varP f, wrap (conP conName (map varP xs))]
                (normalB body)
                []

    -- | Build a clause that constructs an Iso
    makeIsoClause :: Name -> ClauseQ
    makeIsoClause :: Name -> Q Clause
    makeIsoClause Name
    conName = [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] -> 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
    destruct, Q Exp
    construct])) []
      where
      destruct :: Q Exp
    destruct  = do x <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
                     lam1E (conP conName [varP x]) (varE x)

      construct :: Q Exp
    construct = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conName

    ------------------------------------------------------------------------
    -- Unification logic
    ------------------------------------------------------------------------

    -- The field-oriented optic generation supports incorporating fields
    -- with distinct but unifiable types into a single definition.

    -- | Unify the given list of types, if possible, and return the
    -- substitution used to unify the types for unifying the outer
    -- type when building a definition's type signature.
    unifyTypes :: [Type] -> Q (Map Name Type, Type)
    unifyTypes :: [Type] -> Q (Map Name Type, Type)
    unifyTypes (Type
    x:[Type]
    xs) = ((Map Name Type, Type) -> Type -> Q (Map Name Type, Type))
    -> (Map Name Type, Type) -> [Type] -> Q (Map Name Type, Type)
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM ((Map Name Type -> Type -> Type -> Q (Map Name Type, Type))
    -> (Map Name Type, Type) -> Type -> Q (Map Name Type, Type)
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1) (Map Name Type
    forall k a. Map k a
    Map.empty, Type
    x) [Type]
    xs
    unifyTypes []     = String -> Q (Map Name Type, Type)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "unifyTypes: Bug: Unexpected empty list"

    -- | Attempt to unify two given types using a running substitution
    unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub (VarT Name
    x) Type
    y
      | Just Type
    r <- Name -> Map Name Type -> Maybe Type
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    x Map Name Type
    sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub Type
    r Type
    y
    unify1 Map Name Type
    sub Type
    x (VarT Name
    y)
      | Just Type
    r <- Name -> Map Name Type -> Maybe Type
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    y Map Name Type
    sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub Type
    x Type
    r
    unify1 Map Name Type
    sub Type
    x Type
    y
      | Type
    x Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    y = (Map Name Type, Type) -> Q (Map Name Type, Type)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Type
    sub, Type
    x)
    unify1 Map Name Type
    sub (AppT Type
    f1 Type
    x1) (AppT Type
    f2 Type
    x2) =
      do (sub1, f) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub  Type
    f1 Type
    f2
         (sub2, x) <- unify1 sub1 x1 x2
         return (sub2, AppT (applyTypeSubst sub2 f) x)
    unify1 Map Name Type
    sub Type
    x (VarT Name
    y)
      | Getting Any Type Name -> Name -> Type -> Bool
    forall a s. Eq a => Getting Any s a -> a -> s -> Bool
    elemOf Getting Any Type Name
    forall t. HasTypeVars t => Traversal' t Name
    Traversal' Type Name
    typeVars Name
    y (Map Name Type -> Type -> Type
    applyTypeSubst Map Name Type
    sub Type
    x) =
          String -> Q (Map Name Type, Type)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Failed to unify types: occurs check"
      | Bool
    otherwise = (Map Name Type, Type) -> Q (Map Name Type, Type)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Type -> Map Name Type -> Map Name Type
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert Name
    y Type
    x Map Name Type
    sub, Type
    x)
    unify1 Map Name Type
    sub (VarT Name
    x) Type
    y = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub Type
    y (Name -> Type
    VarT Name
    x)

    -- TODO: Unify contexts
    unify1 Map Name Type
    sub (ForallT [TyVarBndrSpec]
    v1 [] Type
    t1) (ForallT [TyVarBndrSpec]
    v2 [] Type
    t2) =
         -- This approach works out because by the time this code runs
         -- all of the type variables have been renamed. No risk of shadowing.
      do (sub1,t) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub Type
    t1 Type
    t2
         v <- fmap nub (traverse (limitedSubst sub1) (v1++v2))
         return (sub1, ForallT v [] t)

    unify1 Map Name Type
    _ Type
    x Type
    y = String -> Q (Map Name Type, Type)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Failed to unify types: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Type, Type) -> String
    forall a. Show a => a -> String
    show (Type
    x,Type
    y))

    -- | Perform a limited substitution on type variables. This is used
    -- when unifying rank-2 fields when trying to achieve a Getter or Fold.
    limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec
    limitedSubst :: Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
    limitedSubst Map Name Type
    sub TyVarBndrSpec
    tv
      | Just Type
    r <- Name -> Map Name Type -> Maybe Type
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup (TyVarBndrSpec -> Name
    forall flag. TyVarBndr_ flag -> Name
    D.tvName TyVarBndrSpec
    tv) Map Name Type
    sub =
           case Type
    r of
             VarT Name
    m -> Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
    limitedSubst Map Name Type
    sub ((Name -> Name) -> TyVarBndrSpec -> TyVarBndrSpec
    forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
    D.mapTVName (Name -> Name -> Name
    forall a b. a -> b -> a
    const Name
    m) TyVarBndrSpec
    tv)
             Type
    _ -> String -> Q TyVarBndrSpec
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Unable to unify exotic higher-rank type"
      | Bool
    otherwise = TyVarBndrSpec -> Q TyVarBndrSpec
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TyVarBndrSpec
    tv

    -- | Apply a substitution to a type. This is used after unifying
    -- the types of the fields in unifyTypes.
    applyTypeSubst :: Map Name Type -> Type -> Type
    applyTypeSubst :: Map Name Type -> Type -> Type
    applyTypeSubst Map Name Type
    sub = (Type -> Maybe Type) -> Type -> Type
    forall a. Plated a => (a -> Maybe a) -> a -> a
    rewrite Type -> Maybe Type
    aux
      where
      aux :: Type -> Maybe Type
    aux (VarT Name
    n) = Name -> Map Name Type -> Maybe Type
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    n Map Name Type
    sub
      aux Type
    _        = Maybe Type
    forall a. Maybe a
    Nothing

    ------------------------------------------------------------------------
    -- Field generation parameters
    ------------------------------------------------------------------------

    -- | Rules to construct lenses for data fields.
    data LensRules = LensRules
      { LensRules -> Bool
    _simpleLenses    :: Bool
      , LensRules -> Bool
    _generateSigs    :: Bool
      , LensRules -> Bool
    _generateClasses :: Bool
      , LensRules -> Bool
    _allowIsos       :: Bool
      , LensRules -> Bool
    _allowUpdates    :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold)
      , LensRules -> Bool
    _lazyPatterns    :: Bool
      , LensRules -> Bool
    _recordSyntax    :: Bool
      , LensRules -> FieldNamer
    _fieldToDef      :: FieldNamer
           -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names
      , LensRules -> ClassyNamer
    _classyLenses    :: ClassyNamer
           -- type name to class name and top method
      }

    -- | The rule to create function names of lenses for data fields.
    --
    -- Although it's sometimes useful, you won't need the first two
    -- arguments most of the time.
    type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for.
                      -> [Name] -- ^ Names of all fields (including the field being named) in the data type.
                      -> Name -- ^ Name of the field being named.
                      -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field.

    -- | Name to give to generated field optics.
    data DefName
      = TopName Name -- ^ Simple top-level definition name
      | MethodName Name Name -- ^ makeFields-style class name and method name
      deriving (Int -> DefName -> String -> String
    [DefName] -> String -> String
    DefName -> String
    (Int -> DefName -> String -> String)
    -> (DefName -> String)
    -> ([DefName] -> String -> String)
    -> Show DefName
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> DefName -> String -> String
    showsPrec :: Int -> DefName -> String -> String
    $cshow :: DefName -> String
    show :: DefName -> String
    $cshowList :: [DefName] -> String -> String
    showList :: [DefName] -> String -> String
    Show, DefName -> DefName -> Bool
    (DefName -> DefName -> Bool)
    -> (DefName -> DefName -> Bool) -> Eq DefName
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: DefName -> DefName -> Bool
    == :: DefName -> DefName -> Bool
    $c/= :: DefName -> DefName -> Bool
    /= :: DefName -> DefName -> Bool
    Eq, Eq DefName
    Eq DefName =>
    (DefName -> DefName -> Ordering)
    -> (DefName -> DefName -> Bool)
    -> (DefName -> DefName -> Bool)
    -> (DefName -> DefName -> Bool)
    -> (DefName -> DefName -> Bool)
    -> (DefName -> DefName -> DefName)
    -> (DefName -> DefName -> DefName)
    -> Ord DefName
    DefName -> DefName -> Bool
    DefName -> DefName -> Ordering
    DefName -> DefName -> DefName
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: DefName -> DefName -> Ordering
    compare :: DefName -> DefName -> Ordering
    $c< :: DefName -> DefName -> Bool
    < :: DefName -> DefName -> Bool
    $c<= :: DefName -> DefName -> Bool
    <= :: DefName -> DefName -> Bool
    $c> :: DefName -> DefName -> Bool
    > :: DefName -> DefName -> Bool
    $c>= :: DefName -> DefName -> Bool
    >= :: DefName -> DefName -> Bool
    $cmax :: DefName -> DefName -> DefName
    max :: DefName -> DefName -> DefName
    $cmin :: DefName -> DefName -> DefName
    min :: DefName -> DefName -> DefName
    Ord)

    -- | The optional rule to create a class and method around a
    -- monomorphic data type. If this naming convention is provided, it
    -- generates a "classy" lens.
    type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for.
                       -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively.

    -- | Tracks the field class 'Name's that have been created so far. We consult
    -- these so that we may avoid creating duplicate classes.

    -- See #643 for more information.
    type HasFieldClasses = StateT (Set Name) Q

    addFieldClassName :: Name -> HasFieldClasses ()
    addFieldClassName :: Name -> HasFieldClasses ()
    addFieldClassName Name
    n = (Set Name -> Set Name) -> HasFieldClasses ()
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
    modify ((Set Name -> Set Name) -> HasFieldClasses ())
    -> (Set Name -> Set Name) -> HasFieldClasses ()
    forall a b. (a -> b) -> a -> b
    $ Name -> Set Name -> Set Name
    forall a. Ord a => a -> Set a -> Set a
    Set.insert Name
    n