    {-# LANGUAGE CPP #-}
    {-# LANGUAGE PatternGuards #-}
    #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 Control.Lens.At
    import Control.Lens.Fold
    import Control.Lens.Internal.TH
    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.Applicative
    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 Data.Maybe (isJust,maybeToList)
    import Data.List (nub, findIndices)
    import Data.Either (partitionEithers)
    import Data.Semigroup
    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
    import Prelude

    ------------------------------------------------------------------------
    -- 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 rules :: 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 rules :: 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' rules :: 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 (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 rules :: LensRules
    rules info :: DatatypeInfo
    info =
      do Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
    perDef <- Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> StateT
         (Set Name)
         Q
         (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
     -> StateT
          (Set Name)
          Q
          (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])))
    -> Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> StateT
         (Set Name)
         Q
         (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
    forall a b. (a -> b) -> a -> b
    $ do
           [(Name, [(Maybe Name, Type)])]
    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)
    traverse ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
    normalizeConstructor [ConstructorInfo]
    cons
           let allFields :: [Name]
    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
    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
    _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
    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
    _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
    folded) [(Name, [(Maybe Name, Type)])]
    fieldCons
           let defCons :: [(Name, [([DefName], Type)])]
    defCons    = ASetter
      [(Name, [(Maybe Name, Type)])]
      [(Name, [([DefName], Type)])]
      (Maybe Name)
      [DefName]
    -> (Maybe Name -> [DefName])
    -> [(Name, [(Maybe Name, Type)])]
    -> [(Name, [([DefName], Type)])]
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over ASetter
      [(Name, [(Maybe Name, Type)])]
      [(Name, [([DefName], Type)])]
      (Maybe Name)
      [DefName]
    forall a b.
    Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
    normFieldLabels ([Name] -> Maybe Name -> [DefName]
    expandName [Name]
    allFields) [(Name, [(Maybe Name, Type)])]
    fieldCons
               allDefs :: Set DefName
    allDefs    = Getting (Set DefName) [(Name, [([DefName], Type)])] DefName
    -> [(Name, [([DefName], Type)])] -> Set DefName
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf (([DefName] -> Const (Set DefName) [DefName])
    -> [(Name, [([DefName], Type)])]
    -> Const (Set DefName) [(Name, [([DefName], Type)])]
    forall a b.
    Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
    normFieldLabels (([DefName] -> Const (Set DefName) [DefName])
     -> [(Name, [([DefName], Type)])]
     -> Const (Set DefName) [(Name, [([DefName], Type)])])
    -> ((DefName -> Const (Set DefName) DefName)
        -> [DefName] -> Const (Set DefName) [DefName])
    -> Getting (Set DefName) [(Name, [([DefName], Type)])] DefName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (DefName -> Const (Set DefName) DefName)
    -> [DefName] -> Const (Set DefName) [DefName]
    forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
    folded) [(Name, [([DefName], Type)])]
    defCons
           Map DefName (Q (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    T.sequenceA ((DefName -> Q (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> Set DefName
    -> Map DefName (Q (OpticType, OpticStab, [(Name, Int, [Int])]))
    forall k v. (k -> v) -> Set k -> Map k v
    fromSet (LensRules
    -> Type
    -> [(Name, [([DefName], Type)])]
    -> DefName
    -> Q (OpticType, OpticStab, [(Name, Int, [Int])])
    buildScaffold LensRules
    rules Type
    s [(Name, [([DefName], Type)])]
    defCons) Set DefName
    allDefs)

         let defs :: [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs = Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
    perDef
         case LensRules -> ClassyNamer
    _classyLenses LensRules
    rules Name
    tyName of
           Just (className :: Name
    className, methodName :: Name
    methodName) ->
             LensRules
    -> Name
    -> Name
    -> Type
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    -> StateT (Set Name) Q [Dec]
    makeClassyDriver LensRules
    rules Name
    className Name
    methodName Type
    s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs
           Nothing -> do [[Dec]]
    decss <- ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
     -> StateT (Set Name) Q [Dec])
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    -> StateT (Set Name) Q [[Dec]]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (LensRules
    -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> StateT (Set Name) Q [Dec]
    makeFieldOptic LensRules
    rules) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs
                         [Dec] -> StateT (Set Name) Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    decss)

      where
      tyName :: Name
    tyName = DatatypeInfo -> Name
    D.datatypeName DatatypeInfo
    info
      s :: Type
    s      = DatatypeInfo -> Type
    D.datatypeType 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 :: (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)
    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
    _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)
    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
    _1

      -- Map a (possibly missing) field's name to zero-to-many optic definitions
      expandName :: [Name] -> Maybe Name -> [DefName]
      expandName :: [Name] -> Maybe Name -> [DefName]
    expandName allFields :: [Name]
    allFields = (Name -> [DefName]) -> [Name] -> [DefName]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (LensRules -> FieldNamer
    _fieldToDef LensRules
    rules Name
    tyName [Name]
    allFields) ([Name] -> [DefName])
    -> (Maybe Name -> [Name]) -> Maybe Name -> [DefName]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Maybe Name -> [Name]
    forall a. Maybe a -> [a]
    maybeToList

    -- | 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 con :: ConstructorInfo
    con =
      (Name, [(Maybe Name, Type)]) -> Q (Name, [(Maybe Name, Type)])
    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 s a. HasTypeVars s => Maybe a -> s -> (Maybe a, s)
    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 xs :: [Name]
    xs -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Maybe Name
    forall a. a -> Maybe a
    Just [Name]
    xs
            D.NormalConstructor    -> Maybe Name -> [Maybe Name]
    forall a. a -> [a]
    repeat Maybe Name
    forall a. Maybe a
    Nothing
            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 -> s -> (Maybe a, s)
    checkForExistentials _ fieldtype :: s
    fieldtype
          | (TyVarBndr -> Bool) -> [TyVarBndr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\tv :: TyVarBndr
    tv -> TyVarBndr -> 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, s
    fieldtype)
          where
            used :: Set Name
    used        = Getting (Set Name) s Name -> s -> Set Name
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf Getting (Set Name) s Name
    forall t. HasTypeVars t => Traversal' t Name
    typeVars s
    fieldtype
            unallowable :: [TyVarBndr]
    unallowable = ConstructorInfo -> [TyVarBndr]
    D.constructorVars ConstructorInfo
    con
        checkForExistentials fieldname :: Maybe a
    fieldname fieldtype :: s
    fieldtype = (Maybe a
    fieldname, s
    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], Type)])]     {- ^ normalized constructors          -} ->
      DefName                           {- ^ target definition                -} ->
      Q (OpticType, OpticStab, [(Name, Int, [Int])])
                  {- ^ optic type, definition type, field count, target fields -}
    buildScaffold :: LensRules
    -> Type
    -> [(Name, [([DefName], Type)])]
    -> DefName
    -> Q (OpticType, OpticStab, [(Name, Int, [Int])])
    buildScaffold rules :: LensRules
    rules s :: Type
    s cons :: [(Name, [([DefName], Type)])]
    cons defName :: DefName
    defName =

      do (s' :: Type
    s',t :: Type
    t,a :: Type
    a,b :: Type
    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 Type])]
    consForDef)

         let defType :: OpticStab
    defType
               | Just (_,cx :: [Type]
    cx,a' :: Type
    a') <- Getting
      (First ([TyVarBndr], [Type], Type))
      Type
      ([TyVarBndr], [Type], Type)
    -> Type -> Maybe ([TyVarBndr], [Type], Type)
    forall s (m :: * -> *) a.
    MonadReader s m =>
    Getting (First a) s a -> m (Maybe a)
    preview Getting
      (First ([TyVarBndr], [Type], Type))
      Type
      ([TyVarBndr], [Type], Type)
    Prism' Type ([TyVarBndr], [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 :: OpticType
    opticType | Getting Any Type ([TyVarBndr], [Type], Type) -> Type -> Bool
    forall s a. Getting Any s a -> s -> Bool
    has Getting Any Type ([TyVarBndr], [Type], Type)
    Prism' Type ([TyVarBndr], [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

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

      scaffolds :: [(Name, Int, [Int])]
      scaffolds :: [(Name, Int, [Int])]
    scaffolds = [ (Name
    n, [Either Type Type] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Either Type Type]
    ts, [Either Type Type] -> [Int]
    rightIndices [Either Type Type]
    ts) | (n :: Name
    n,ts :: [Either Type Type]
    ts) <- [(Name, [Either Type Type])]
    consForDef ]

      rightIndices :: [Either Type Type] -> [Int]
      rightIndices :: [Either Type Type] -> [Int]
    rightIndices = (Either Type Type -> Bool) -> [Either Type Type] -> [Int]
    forall a. (a -> Bool) -> [a] -> [Int]
    findIndices (Getting Any (Either Type Type) Type -> Either Type Type -> Bool
    forall s a. Getting Any s a -> s -> Bool
    has Getting Any (Either Type Type) Type
    forall c a b. Prism (Either c a) (Either c b) a b
    _Right)

      -- Right: types for this definition
      -- Left : other types
      categorize :: ([DefName], Type) -> Either Type Type
      categorize :: ([DefName], Type) -> Either Type Type
    categorize (defNames :: [DefName]
    defNames, t :: Type
    t)
        | DefName
    defName DefName -> [DefName] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [DefName]
    defNames = Type -> Either Type Type
    forall a b. b -> Either a b
    Right Type
    t
        | Bool
    otherwise               = Type -> Either Type Type
    forall a b. a -> Either a b
    Left  Type
    t

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

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

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

    stabToType :: OpticStab -> Type
    stabToType :: OpticStab -> Type
    stabToType (OpticStab  c :: Name
    c s :: Type
    s t :: Type
    t a :: Type
    a b :: Type
    b) = [Type] -> Type -> Type
    quantifyType [] (Name
    c Name -> [Type] -> Type
    `conAppsT` [Type
    s,Type
    t,Type
    a,Type
    b])
    stabToType (OpticSa cx :: [Type]
    cx c :: Name
    c s :: Type
    s   a :: 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 cx :: [Type]
    cx _ _ _) = [Type]
    cx

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

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

    stabToA :: OpticStab -> Type
    stabToA :: OpticStab -> Type
    stabToA (OpticStab _ _ _ a :: Type
    a _) = Type
    a
    stabToA (OpticSa _ _ _ a :: 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 s :: Type
    s categorizedFields :: [Either Type Type]
    categorizedFields =
      do (subA :: Map Name Type
    subA,a :: Type
    a) <- [Type] -> Q (Map Name Type, Type)
    unifyTypes [Type]
    targetFields
         let s' :: Type
    s' = Map Name Type -> Type -> Type
    applyTypeSubst Map Name Type
    subA Type
    s

         -- compute possible type changes
         Map Name Name
    sub <- Map Name (Q Name) -> Q (Map Name Name)
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    T.sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
    forall k v. (k -> v) -> Set k -> Map k v
    fromSet (String -> Q Name
    newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase) Set Name
    unfixedTypeVars)
         let (t :: Type
    t,b :: Type
    b) = ASetter (Type, Type) (Type, Type) Type Type
    -> (Type -> Type) -> (Type, Type) -> (Type, Type)
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over ASetter (Type, Type) (Type, Type) Type Type
    forall (r :: * -> * -> *) a b.
    Bitraversable r =>
    Traversal (r a a) (r b b) a b
    both (Map Name Name -> Type -> Type
    forall t. HasTypeVars t => Map Name Name -> t -> t
    substTypeVars Map Name Name
    sub) (Type
    s',Type
    a)

         (Type, Type, Type, Type) -> Q (Type, Type, Type, Type)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    s',Type
    t,Type
    a,Type
    b)

      where
      (fixedFields :: [Type]
    fixedFields, targetFields :: [Type]
    targetFields) = [Either Type Type] -> ([Type], [Type])
    forall a b. [Either a b] -> ([a], [b])
    partitionEithers [Either Type Type]
    categorizedFields
      fixedTypeVars :: Set Name
    fixedTypeVars               = 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
    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
    typeVars Type
    s Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.\\ Set Name
    fixedTypeVars

    -- | 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, [Int])])) ->
      HasFieldClasses [Dec]
    makeFieldOptic :: LensRules
    -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> StateT (Set Name) Q [Dec]
    makeFieldOptic rules :: LensRules
    rules (defName :: DefName
    defName, (opticType :: OpticType
    opticType, defType :: OpticStab
    defType, cons :: [(Name, Int, [Int])]
    cons)) = do
      Set Name
    locals <- StateT (Set Name) Q (Set Name)
    forall s (m :: * -> *). MonadState s m => m s
    get
      HasFieldClasses ()
    addName
      DecsQ -> StateT (Set Name) Q [Dec]
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (DecsQ -> StateT (Set Name) Q [Dec])
    -> DecsQ -> StateT (Set Name) Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ do [DecQ]
    cls <- Set Name -> Q [DecQ]
    mkCls Set Name
    locals
                [DecQ] -> DecsQ
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    T.sequenceA ([DecQ]
    cls [DecQ] -> [DecQ] -> [DecQ]
    forall a. [a] -> [a] -> [a]
    ++ [DecQ]
    sig [DecQ] -> [DecQ] -> [DecQ]
    forall a. [a] -> [a] -> [a]
    ++ [DecQ]
    def)
      where
      mkCls :: Set Name -> Q [DecQ]
    mkCls locals :: Set Name
    locals = case DefName
    defName of
                     MethodName c :: Name
    c n :: Name
    n | LensRules -> Bool
    _generateClasses LensRules
    rules ->
                      do Bool
    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)
                         [DecQ] -> Q [DecQ]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (if Bool
    classExists Bool -> Bool -> Bool
    || Name -> Set Name -> Bool
    forall a. Ord a => a -> Set a -> Bool
    Set.member Name
    c Set Name
    locals then [] else [OpticStab -> Name -> Name -> DecQ
    makeFieldClass OpticStab
    defType Name
    c Name
    n])
                     _ -> [DecQ] -> Q [DecQ]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

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

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

      fun :: Name -> [DecQ]
    fun n :: Name
    n = Name -> [ClauseQ] -> DecQ
    funD Name
    n [ClauseQ]
    clauses DecQ -> [DecQ] -> [DecQ]
    forall a. a -> [a] -> [a]
    : Name -> [DecQ]
    inlinePragma Name
    n

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

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

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

    makeClassyDriver ::
      LensRules ->
      Name ->
      Name ->
      Type {- ^ Outer 's' type -} ->
      [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
      HasFieldClasses [Dec]
    makeClassyDriver :: LensRules
    -> Name
    -> Name
    -> Type
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    -> StateT (Set Name) Q [Dec]
    makeClassyDriver rules :: LensRules
    rules className :: Name
    className methodName :: Name
    methodName s :: Type
    s defs :: [(DefName, (OpticType, OpticStab, [(Name, Int, [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)
    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 (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, [Int])]))]
    -> DecQ
    makeClassyClass Name
    className Name
    methodName Type
    s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs]
          | Bool
    otherwise = []

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

    makeClassyClass ::
      Name ->
      Name ->
      Type {- ^ Outer 's' type -} ->
      [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
      DecQ
    makeClassyClass :: Name
    -> Name
    -> Type
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    -> DecQ
    makeClassyClass className :: Name
    className methodName :: Name
    methodName s :: Type
    s defs :: [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs = do
      let ss :: [Type]
    ss   = ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) -> Type)
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (OpticStab -> Type
    stabToS (OpticStab -> Type)
    -> ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
        -> OpticStab)
    -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Getting
      OpticStab
      (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
      OpticStab
    -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> OpticStab
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view (((OpticType, OpticStab, [(Name, Int, [Int])])
     -> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> Const
         OpticStab (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    forall s t a b. Field2 s t a b => Lens s t a b
    _2 (((OpticType, OpticStab, [(Name, Int, [Int])])
      -> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
     -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
     -> Const
          OpticStab (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])))
    -> ((OpticStab -> Const OpticStab OpticStab)
        -> (OpticType, OpticStab, [(Name, Int, [Int])])
        -> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> Getting
         OpticStab
         (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
         OpticStab
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (OpticStab -> Const OpticStab OpticStab)
    -> (OpticType, OpticStab, [(Name, Int, [Int])])
    -> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])])
    forall s t a b. Field2 s t a b => Lens s t a b
    _2)) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs
      (sub :: Map Name Type
    sub,s' :: Type
    s') <- [Type] -> Q (Map Name Type, Type)
    unifyTypes (Type
    s Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : [Type]
    ss)
      Name
    c <- String -> Q Name
    newName "c"
      let vars :: [Name]
    vars = Getting (Endo [Name]) Type Name -> Type -> [Name]
    forall a s. Getting (Endo [a]) s a -> s -> [a]
    toListOf Getting (Endo [Name]) Type Name
    forall t. HasTypeVars t => Traversal' t Name
    typeVars Type
    s'
          fd :: [FunDep]
    fd   | [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    vars = []
               | Bool
    otherwise = [[Name] -> [Name] -> FunDep
    FunDep [Name
    c] [Name]
    vars]

      CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
    classD ([TypeQ] -> CxtQ
    cxt[]) Name
    className ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> TyVarBndr
    PlainTV (Name
    cName -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    :[Name]
    vars)) [FunDep]
    fd
        ([DecQ] -> DecQ) -> [DecQ] -> DecQ
    forall a b. (a -> b) -> a -> b
    $ Name -> TypeQ -> DecQ
    sigD Name
    methodName (Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name
    lens'TypeName Name -> [Type] -> Type
    `conAppsT` [Name -> Type
    VarT Name
    c, Type
    s']))
        DecQ -> [DecQ] -> [DecQ]
    forall a. a -> [a] -> [a]
    : [[DecQ]] -> [DecQ]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
          [ [Name -> TypeQ -> DecQ
    sigD Name
    defName (Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)
            ,PatQ -> BodyQ -> [DecQ] -> DecQ
    valD (Name -> PatQ
    varP Name
    defName) (ExpQ -> BodyQ
    normalB ExpQ
    body) []
            ] [DecQ] -> [DecQ] -> [DecQ]
    forall a. [a] -> [a] -> [a]
    ++
            Name -> [DecQ]
    inlinePragma Name
    defName
          | (TopName defName :: Name
    defName, (_, stab :: OpticStab
    stab, _)) <- [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs
          , let body :: ExpQ
    body = [ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE Name
    composeValName, Name -> ExpQ
    varE Name
    methodName, Name -> ExpQ
    varE Name
    defName]
          , let ty :: Type
    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]
    vars))
                                     (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, [Int])]))] ->
      HasFieldClasses Dec
    makeClassyInstance :: LensRules
    -> Name
    -> Name
    -> Type
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    -> StateT (Set Name) Q Dec
    makeClassyInstance rules :: LensRules
    rules className :: Name
    className methodName :: Name
    methodName s :: Type
    s defs :: [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs = do
      [[Dec]]
    methodss <- ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
     -> StateT (Set Name) Q [Dec])
    -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    -> StateT (Set Name) Q [[Dec]]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (LensRules
    -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
    -> StateT (Set Name) Q [Dec]
    makeFieldOptic LensRules
    rules') [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
    defs

      DecQ -> StateT (Set Name) Q Dec
    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
    $ CxtQ -> TypeQ -> [DecQ] -> DecQ
    instanceD ([TypeQ] -> CxtQ
    cxt[]) (Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    instanceHead)
               ([DecQ] -> DecQ) -> [DecQ] -> DecQ
    forall a b. (a -> b) -> a -> b
    $ PatQ -> BodyQ -> [DecQ] -> DecQ
    valD (Name -> PatQ
    varP Name
    methodName) (ExpQ -> BodyQ
    normalB (Name -> ExpQ
    varE Name
    idValName)) []
               DecQ -> [DecQ] -> [DecQ]
    forall a. a -> [a] -> [a]
    : (Dec -> DecQ) -> [Dec] -> [DecQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Dec -> DecQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    methodss)

      where
      instanceHead :: Type
    instanceHead = Name
    className Name -> [Type] -> Type
    `conAppsT` (Type
    s Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : (Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    vars)
      vars :: [Name]
    vars         = Getting (Endo [Name]) Type Name -> Type -> [Name]
    forall a s. Getting (Endo [a]) s a -> s -> [a]
    toListOf Getting (Endo [Name]) Type Name
    forall t. HasTypeVars t => Traversal' t Name
    typeVars Type
    s
      rules' :: LensRules
    rules'       = LensRules
    rules { _generateSigs :: Bool
    _generateSigs    = Bool
    False
                           , _generateClasses :: Bool
    _generateClasses = Bool
    False
                           }

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

    makeFieldClass :: OpticStab -> Name -> Name -> DecQ
    makeFieldClass :: OpticStab -> Name -> Name -> DecQ
    makeFieldClass defType :: OpticStab
    defType className :: Name
    className methodName :: Name
    methodName =
      CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
    classD ([TypeQ] -> CxtQ
    cxt []) Name
    className [Name -> TyVarBndr
    PlainTV Name
    s, Name -> TyVarBndr
    PlainTV Name
    a] [[Name] -> [Name] -> FunDep
    FunDep [Name
    s] [Name
    a]]
             [Name -> TypeQ -> DecQ
    sigD Name
    methodName (Type -> TypeQ
    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 "s"
      a :: Name
    a = String -> Name
    mkName "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 defType :: OpticStab
    defType className :: Name
    className decs :: [DecQ]
    decs =
      Type -> Q Bool
    containsTypeFamilies Type
    a Q Bool -> (Bool -> DecQ) -> DecQ
    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 -> TypeQ) -> Type -> Q Bool
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< Type -> TypeQ
    D.resolveTypeSynonyms
        where
        go :: Type -> Q Bool
    go (ConT nm :: Name
    nm) = 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
    _1 ((Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
    -> ((() -> Const Any ()) -> Dec -> Const Any Dec)
    -> (() -> Const Any ())
    -> (Dec, [Dec])
    -> Const Any (Dec, [Dec])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (() -> Const Any ()) -> Dec -> Const 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 ty :: 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)
    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
    plate)

        -- We want to catch type families, but not *data* families. See #799.
        _TypeFamilyD :: Getting Any Dec ()
        _TypeFamilyD :: (() -> Const Any ()) -> Dec -> Const 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)
    -> (() -> Const Any ())
    -> Dec
    -> Const Any Dec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .(() -> Const Any ()) -> TypeFamilyHead -> Const Any TypeFamilyHead
    forall a. Lens' a ()
    united ((() -> Const Any ()) -> Dec -> Const Any Dec)
    -> ((() -> Const Any ()) -> Dec -> Const Any Dec)
    -> (() -> Const Any ())
    -> Dec
    -> Const 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]))
    -> (() -> Const Any ())
    -> Dec
    -> Const Any Dec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .(() -> Const Any ())
    -> (TypeFamilyHead, [TySynEqn])
    -> Const Any (TypeFamilyHead, [TySynEqn])
    forall a. Lens' a ()
    united
          where
    #if !(MIN_VERSION_template_haskell(2,11,0))
          _OpenTypeFamilyD = _FamilyD . _1 . _TypeFam
    #endif
    #if !(MIN_VERSION_template_haskell(2,9,0))
          _ClosedTypeFamilyD = ignored
    #endif

      pickInstanceDec :: Bool -> DecQ
    pickInstanceDec hasFamilies :: Bool
    hasFamilies
        | Bool
    hasFamilies = do
            Type
    placeholder <- Name -> Type
    VarT (Name -> Type) -> Q Name -> TypeQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    newName "a"
            [TypeQ] -> [Type] -> DecQ
    mkInstanceDec
              [Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type -> Type
    D.equalPred Type
    placeholder Type
    a)]
              [Type
    s, Type
    placeholder]
        | Bool
    otherwise = [TypeQ] -> [Type] -> DecQ
    mkInstanceDec [] [Type
    s, Type
    a]

      mkInstanceDec :: [TypeQ] -> [Type] -> DecQ
    mkInstanceDec context :: [TypeQ]
    context headTys :: [Type]
    headTys =
        CxtQ -> TypeQ -> [DecQ] -> DecQ
    instanceD ([TypeQ] -> CxtQ
    cxt [TypeQ]
    context) (Type -> TypeQ
    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, [Int])] -> [ClauseQ]
    makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
    makeFieldClauses rules :: LensRules
    rules opticType :: OpticType
    opticType cons :: [(Name, Int, [Int])]
    cons =
      case OpticType
    opticType of

        IsoType    -> [ Name -> ClauseQ
    makeIsoClause Name
    conName | (conName :: Name
    conName, _, _) <- [(Name, Int, [Int])]
    cons ]

        GetterType -> [ Name -> Int -> [Int] -> ClauseQ
    makeGetterClause Name
    conName Int
    fieldCount [Int]
    fields
                        | (conName :: Name
    conName, fieldCount :: Int
    fieldCount, fields :: [Int]
    fields) <- [(Name, Int, [Int])]
    cons ]

        LensType   -> [ Name -> Int -> [Int] -> Bool -> ClauseQ
    makeFieldOpticClause Name
    conName Int
    fieldCount [Int]
    fields Bool
    irref
                        | (conName :: Name
    conName, fieldCount :: Int
    fieldCount, fields :: [Int]
    fields) <- [(Name, Int, [Int])]
    cons ]
          where
          irref :: Bool
    irref = LensRules -> Bool
    _lazyPatterns LensRules
    rules
               Bool -> Bool -> Bool
    && [(Name, Int, [Int])] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Name, Int, [Int])]
    cons Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 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 -> ClauseQ
    makePureClause conName :: Name
    conName fieldCount :: Int
    fieldCount =
      do [Name]
    xs <- String -> Int -> Q [Name]
    newNames "x" Int
    fieldCount
         -- clause: _ (Con x1..xn) = pure (Con x1..xn)
         [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [PatQ
    wildP, Name -> [PatQ] -> PatQ
    conP Name
    conName ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    xs)]
                (ExpQ -> BodyQ
    normalB (ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    varE Name
    pureValName) ([ExpQ] -> ExpQ
    appsE (Name -> ExpQ
    conE Name
    conName ExpQ -> [ExpQ] -> [ExpQ]
    forall a. a -> [a] -> [a]
    : (Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    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] -> ClauseQ
    makeGetterClause conName :: Name
    conName fieldCount :: Int
    fieldCount []     = Name -> Int -> ClauseQ
    makePureClause Name
    conName Int
    fieldCount
    makeGetterClause conName :: Name
    conName fieldCount :: Int
    fieldCount fields :: [Int]
    fields =
      do Name
    f  <- String -> Q Name
    newName "f"
         [Name]
    xs <- String -> Int -> Q [Name]
    newNames "x" ([Int] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Int]
    fields)

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

             fxs :: [ExpQ]
    fxs   = [ ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    varE Name
    f) (Name -> ExpQ
    varE Name
    x) | Name
    x <- [Name]
    xs ]
             body :: ExpQ
    body  = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\a :: ExpQ
    a b :: ExpQ
    b -> [ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE Name
    apValName, ExpQ
    a, ExpQ
    b])
                           (ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    varE Name
    phantomValName) ([ExpQ] -> ExpQ
    forall a. [a] -> a
    head [ExpQ]
    fxs))
                           ([ExpQ] -> [ExpQ]
    forall a. [a] -> [a]
    tail [ExpQ]
    fxs)

         -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn
         [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [Name -> PatQ
    varP Name
    f, Name -> [PatQ] -> PatQ
    conP Name
    conName ([Int] -> [Name] -> [PatQ]
    pats [0..Int
    fieldCount Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 1] [Name]
    xs)]
                (ExpQ -> BodyQ
    normalB ExpQ
    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 -> [Int] -> Bool -> ClauseQ
    makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ
    makeFieldOpticClause conName :: Name
    conName fieldCount :: Int
    fieldCount [] _ =
      Name -> Int -> ClauseQ
    makePureClause Name
    conName Int
    fieldCount
    makeFieldOpticClause conName :: Name
    conName fieldCount :: Int
    fieldCount (field :: Int
    field:fields :: [Int]
    fields) irref :: Bool
    irref =
      do Name
    f  <- String -> Q Name
    newName "f"
         [Name]
    xs <- String -> Int -> Q [Name]
    newNames "x" Int
    fieldCount
         [Name]
    ys <- String -> Int -> Q [Name]
    newNames "y" (1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Int]
    fields)

         let xs' :: [Name]
    xs' = ((Int, Name) -> [Name] -> [Name])
    -> [Name] -> [(Int, Name)] -> [Name]
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\(i :: Int
    i,x :: 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 -> ExpQ
    mkFx i :: Int
    i = ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    varE Name
    f) (Name -> ExpQ
    varE ([Name]
    xs [Name] -> Int -> Name
    forall a. [a] -> Int -> a
    !! Int
    i))

             body0 :: ExpQ
    body0 = [ExpQ] -> ExpQ
    appsE [ Name -> ExpQ
    varE Name
    fmapValName
                           , [PatQ] -> ExpQ -> ExpQ
    lamE ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    ys) ([ExpQ] -> ExpQ
    appsE (Name -> ExpQ
    conE Name
    conName ExpQ -> [ExpQ] -> [ExpQ]
    forall a. a -> [a] -> [a]
    : (Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    xs'))
                           , Int -> ExpQ
    mkFx Int
    field
                           ]

             body :: ExpQ
    body = (ExpQ -> Int -> ExpQ) -> ExpQ -> [Int] -> ExpQ
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\a :: ExpQ
    a b :: Int
    b -> [ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE Name
    apValName, ExpQ
    a, Int -> ExpQ
    mkFx Int
    b]) ExpQ
    body0 [Int]
    fields

         let wrap :: PatQ -> PatQ
    wrap = if Bool
    irref then PatQ -> PatQ
    tildeP else PatQ -> PatQ
    forall a. a -> a
    id

         [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [Name -> PatQ
    varP Name
    f, PatQ -> PatQ
    wrap (Name -> [PatQ] -> PatQ
    conP Name
    conName ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    xs))]
                (ExpQ -> BodyQ
    normalB ExpQ
    body)
                []

    -- | Build a clause that constructs an Iso
    makeIsoClause :: Name -> ClauseQ
    makeIsoClause :: Name -> ClauseQ
    makeIsoClause conName :: Name
    conName = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [] (ExpQ -> BodyQ
    normalB ([ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE Name
    isoValName, ExpQ
    destruct, ExpQ
    construct])) []
      where
      destruct :: ExpQ
    destruct  = do Name
    x <- String -> Q Name
    newName "x"
                     PatQ -> ExpQ -> ExpQ
    lam1E (Name -> [PatQ] -> PatQ
    conP Name
    conName [Name -> PatQ
    varP Name
    x]) (Name -> ExpQ
    varE Name
    x)

      construct :: ExpQ
    construct = Name -> ExpQ
    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 (x :: Type
    x:xs :: [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 (m :: * -> *) a. MonadFail m => String -> m a
    fail "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 sub :: Map Name Type
    sub (VarT x :: Name
    x) y :: Type
    y
      | Just r :: 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 sub :: Map Name Type
    sub x :: Type
    x (VarT y :: Name
    y)
      | Just r :: 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 sub :: Map Name Type
    sub x :: Type
    x y :: 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 (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Type
    sub, Type
    x)
    unify1 sub :: Map Name Type
    sub (AppT f1 :: Type
    f1 x1 :: Type
    x1) (AppT f2 :: Type
    f2 x2 :: Type
    x2) =
      do (sub1 :: Map Name Type
    sub1, f :: Type
    f) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub  Type
    f1 Type
    f2
         (sub2 :: Map Name Type
    sub2, x :: Type
    x) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub1 Type
    x1 Type
    x2
         (Map Name Type, Type) -> Q (Map Name Type, Type)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Type
    sub2, Type -> Type -> Type
    AppT (Map Name Type -> Type -> Type
    applyTypeSubst Map Name Type
    sub2 Type
    f) Type
    x)
    unify1 sub :: Map Name Type
    sub x :: Type
    x (VarT y :: 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
    typeVars Name
    y (Map Name Type -> Type -> Type
    applyTypeSubst Map Name Type
    sub Type
    x) =
          String -> Q (Map Name Type, Type)
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "Failed to unify types: occurs check"
      | Bool
    otherwise = (Map Name Type, Type) -> Q (Map Name Type, Type)
    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 sub :: Map Name Type
    sub (VarT x :: Name
    x) y :: 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 sub :: Map Name Type
    sub (ForallT v1 :: [TyVarBndr]
    v1 [] t1 :: Type
    t1) (ForallT v2 :: [TyVarBndr]
    v2 [] t2 :: 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 :: Map Name Type
    sub1,t :: Type
    t) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
    unify1 Map Name Type
    sub Type
    t1 Type
    t2
         [TyVarBndr]
    v <- ([TyVarBndr] -> [TyVarBndr]) -> Q [TyVarBndr] -> Q [TyVarBndr]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [TyVarBndr] -> [TyVarBndr]
    forall a. Eq a => [a] -> [a]
    nub ((TyVarBndr -> Q TyVarBndr) -> [TyVarBndr] -> Q [TyVarBndr]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (Map Name Type -> TyVarBndr -> Q TyVarBndr
    limitedSubst Map Name Type
    sub1) ([TyVarBndr]
    v1[TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
    forall a. [a] -> [a] -> [a]
    ++[TyVarBndr]
    v2))
         (Map Name Type, Type) -> Q (Map Name Type, Type)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Type
    sub1, [TyVarBndr] -> [Type] -> Type -> Type
    ForallT [TyVarBndr]
    v [] Type
    t)

    unify1 _ x :: Type
    x y :: Type
    y = String -> Q (Map Name Type, Type)
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail ("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 -> TyVarBndr -> Q TyVarBndr
    limitedSubst :: Map Name Type -> TyVarBndr -> Q TyVarBndr
    limitedSubst sub :: Map Name Type
    sub (PlainTV n :: Name
    n)
      | Just r :: Type
    r <- 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 =
           case Type
    r of
             VarT m :: Name
    m -> Map Name Type -> TyVarBndr -> Q TyVarBndr
    limitedSubst Map Name Type
    sub (Name -> TyVarBndr
    PlainTV Name
    m)
             _ -> String -> Q TyVarBndr
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "Unable to unify exotic higher-rank type"
    limitedSubst sub :: Map Name Type
    sub (KindedTV n :: Name
    n k :: Type
    k)
      | Just r :: Type
    r <- 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 =
           case Type
    r of
             VarT m :: Name
    m -> Map Name Type -> TyVarBndr -> Q TyVarBndr
    limitedSubst Map Name Type
    sub (Name -> Type -> TyVarBndr
    KindedTV Name
    m Type
    k)
             _ -> String -> Q TyVarBndr
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "Unable to unify exotic higher-rank type"
    limitedSubst _ tv :: TyVarBndr
    tv = TyVarBndr -> Q TyVarBndr
    forall (m :: * -> *) a. Monad m => a -> m a
    return TyVarBndr
    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 sub :: 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 n :: 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 _        = 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 -> 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 definiton 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
    showList :: [DefName] -> String -> String
    $cshowList :: [DefName] -> String -> String
    show :: DefName -> String
    $cshow :: DefName -> String
    showsPrec :: Int -> DefName -> String -> String
    $cshowsPrec :: Int -> 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
    /= :: DefName -> DefName -> Bool
    $c/= :: DefName -> DefName -> Bool
    == :: DefName -> DefName -> Bool
    $c== :: 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
    min :: DefName -> DefName -> DefName
    $cmin :: DefName -> DefName -> DefName
    max :: DefName -> DefName -> DefName
    $cmax :: DefName -> DefName -> DefName
    >= :: DefName -> DefName -> Bool
    $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
    compare :: DefName -> DefName -> Ordering
    $ccompare :: DefName -> DefName -> Ordering
    $cp1Ord :: Eq 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 n :: 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

    ------------------------------------------------------------------------
    -- Miscellaneous utility functions
    ------------------------------------------------------------------------

    -- | Template Haskell wants type variables declared in a forall, so
    -- we find all free type variables in a given type and declare them.
    quantifyType :: Cxt -> Type -> Type
    quantifyType :: [Type] -> Type -> Type
    quantifyType = Set Name -> [Type] -> Type -> Type
    quantifyType' Set Name
    forall a. Set a
    Set.empty

    -- | This function works like 'quantifyType' except that it takes
    -- a list of variables to exclude from quantification.
    quantifyType' :: Set Name -> Cxt -> Type -> Type
    quantifyType' :: Set Name -> [Type] -> Type -> Type
    quantifyType' exclude :: Set Name
    exclude c :: [Type]
    c t :: Type
    t = [TyVarBndr] -> [Type] -> Type -> Type
    ForallT [TyVarBndr]
    vs [Type]
    c Type
    t
      where
      vs :: [TyVarBndr]
    vs = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> TyVarBndr
    PlainTV
         ([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
    forall a b. (a -> b) -> a -> b
    $ (Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Name -> Set Name -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.notMember` Set Name
    exclude)
         ([Name] -> [Name]) -> [Name] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [Name]
    forall a. Eq a => [a] -> [a]
    nub -- stable order
         ([Name] -> [Name]) -> [Name] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ Getting (Endo [Name]) Type Name -> Type -> [Name]
    forall a s. Getting (Endo [a]) s a -> s -> [a]
    toListOf Getting (Endo [Name]) Type Name
    forall t. HasTypeVars t => Traversal' t Name
    typeVars Type
    t