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

    #include "lens-common.h"

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Lens.Internal.TH
    -- Copyright   :  (C) 2013-2016 Edward Kmett and Eric Mertens
    -- License     :  BSD-style (see the file LICENSE)
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    ----------------------------------------------------------------------------
    module Control.Lens.Internal.TH
      ( module Control.Lens.Internal.TH
    #if MIN_VERSION_template_haskell(2,21,0) || MIN_VERSION_th_abstraction(0,6,0)
      , D.TyVarBndrVis
      , D.bndrReq
    #endif
      ) where

    import Control.Lens.Iso
    import Control.Lens.Prism
    import Control.Lens.Review
    import Control.Lens.Type
    import Control.Lens.Wrapped
    import Data.Functor.Contravariant
    import qualified Data.Set as Set
    import Data.Set (Set)
    import Language.Haskell.TH
    import qualified Language.Haskell.TH.Datatype as D
    import qualified Language.Haskell.TH.Datatype.TyVarBndr as D

    -- | Apply arguments to a type constructor
    appsT :: TypeQ -> [TypeQ] -> TypeQ
    appsT :: TypeQ -> [TypeQ] -> TypeQ
    appsT = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl TypeQ -> TypeQ -> TypeQ
    forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
    appT

    -- | Apply arguments to a function
    appsE1 :: ExpQ -> [ExpQ] -> ExpQ
    appsE1 :: ExpQ -> [ExpQ] -> ExpQ
    appsE1 = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl ExpQ -> ExpQ -> ExpQ
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE

    -- | Construct a tuple type given a list of types.
    toTupleT :: [TypeQ] -> TypeQ
    toTupleT :: [TypeQ] -> TypeQ
    toTupleT [TypeQ
    x] = TypeQ
    x
    toTupleT [TypeQ]
    xs = TypeQ -> [TypeQ] -> TypeQ
    appsT (Int -> TypeQ
    forall (m :: * -> *). Quote m => Int -> m Kind
    tupleT ([TypeQ] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [TypeQ]
    xs)) [TypeQ]
    xs

    -- | Construct a tuple value given a list of expressions.
    toTupleE :: [ExpQ] -> ExpQ
    toTupleE :: [ExpQ] -> ExpQ
    toTupleE [ExpQ
    x] = ExpQ
    x
    toTupleE [ExpQ]
    xs = [ExpQ] -> ExpQ
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    tupE [ExpQ]
    xs

    -- | Construct a tuple pattern given a list of patterns.
    toTupleP :: [PatQ] -> PatQ
    toTupleP :: [PatQ] -> PatQ
    toTupleP [PatQ
    x] = PatQ
    x
    toTupleP [PatQ]
    xs = [PatQ] -> PatQ
    forall (m :: * -> *). Quote m => [m Pat] -> m Pat
    tupP [PatQ]
    xs

    -- | Apply arguments to a type constructor.
    conAppsT :: Name -> [Type] -> Type
    conAppsT :: Name -> [Kind] -> Kind
    conAppsT Name
    conName = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Kind -> Kind -> Kind
    AppT (Name -> Kind
    ConT Name
    conName)

    -- | Generate many new names from a given base name.
    newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name]
    newNames :: String -> Int -> Q [Name]
    newNames String
    base Int
    n = [Q Name] -> Q [Name]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName (String
    baseString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Int -> String
    forall a. Show a => a -> String
    show Int
    i) | Int
    i <- [Int
    1..Int
    n] ]

    -- | Decompose an applied type into its individual components. For example, this:
    --
    -- @
    -- Either Int Char
    -- @
    --
    -- would be unfolded to this:
    --
    -- @
    -- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char])
    -- @
    --
    -- This function ignores explicit parentheses and visible kind applications.
    unfoldType :: Type -> (Type, [Type])
    unfoldType :: Kind -> (Kind, [Kind])
    unfoldType = [Kind] -> Kind -> (Kind, [Kind])
    go []
      where
        go :: [Type] -> Type -> (Type, [Type])
        go :: [Kind] -> Kind -> (Kind, [Kind])
    go [Kind]
    acc (ForallT [TyVarBndr Specificity]
    _ [Kind]
    _ Kind
    ty) = [Kind] -> Kind -> (Kind, [Kind])
    go [Kind]
    acc Kind
    ty
        go [Kind]
    acc (AppT Kind
    ty1 Kind
    ty2)   = [Kind] -> Kind -> (Kind, [Kind])
    go (Kind
    ty2Kind -> [Kind] -> [Kind]
    forall a. a -> [a] -> [a]
    :[Kind]
    acc) Kind
    ty1
        go [Kind]
    acc (SigT Kind
    ty Kind
    _)      = [Kind] -> Kind -> (Kind, [Kind])
    go [Kind]
    acc Kind
    ty
        go [Kind]
    acc (ParensT Kind
    ty)     = [Kind] -> Kind -> (Kind, [Kind])
    go [Kind]
    acc Kind
    ty
    #if MIN_VERSION_template_haskell(2,15,0)
        go [Kind]
    acc (AppKindT Kind
    ty Kind
    _)  = [Kind] -> Kind -> (Kind, [Kind])
    go [Kind]
    acc Kind
    ty
    #endif
        go [Kind]
    acc Kind
    ty               = (Kind
    ty, [Kind]
    acc)

    -- Construct a 'Type' using the datatype's type constructor and type
    -- parameters. Unlike 'D.datatypeType', kind signatures are preserved to
    -- some extent. (See the comments for 'dropSigsIfNonDataFam' below for more
    -- details on this.)
    datatypeTypeKinded :: D.DatatypeInfo -> Type
    datatypeTypeKinded :: DatatypeInfo -> Kind
    datatypeTypeKinded DatatypeInfo
    di
      = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Kind -> Kind -> Kind
    AppT (Name -> Kind
    ConT (DatatypeInfo -> Name
    D.datatypeName DatatypeInfo
    di))
      ([Kind] -> Kind) -> [Kind] -> Kind
    forall a b. (a -> b) -> a -> b
    $ DatatypeInfo -> [Kind] -> [Kind]
    dropSigsIfNonDataFam DatatypeInfo
    di
      ([Kind] -> [Kind]) -> [Kind] -> [Kind]
    forall a b. (a -> b) -> a -> b
    $ DatatypeInfo -> [Kind]
    D.datatypeInstTypes DatatypeInfo
    di

    -- | In an effort to prevent users from having to enable KindSignatures every
    -- time that they use lens' TH functionality, we strip off reified kind
    -- annotations from when:
    --
    -- 1. The kind of a type does not contain any kind variables. If it *does*
    --    contain kind variables, we want to preserve them so that we can generate
    --    type signatures that preserve the dependency order of kind and type
    --    variables. (The data types in test/T917.hs contain examples where this
    --    is important.) This will require enabling `PolyKinds`, but since
    --    `PolyKinds` implies `KindSignatures`, we can at least accomplish two
    --    things at once.
    -- 2. The data type is not an instance of a data family. We make an exception
    --    for data family instances, since the presence or absence of a kind
    --    annotation can be the difference between typechecking or not.
    --    (See T917DataFam in tests/T917.hs for an example.) Moreover, the
    --    `TypeFamilies` extension implies `KindSignatures`.
    dropSigsIfNonDataFam :: D.DatatypeInfo -> [Type] -> [Type]
    dropSigsIfNonDataFam :: DatatypeInfo -> [Kind] -> [Kind]
    dropSigsIfNonDataFam DatatypeInfo
    di
      | DatatypeVariant -> Bool
    isDataFamily (DatatypeInfo -> DatatypeVariant
    D.datatypeVariant DatatypeInfo
    di) = [Kind] -> [Kind]
    forall a. a -> a
    id
      | Bool
    otherwise                           = (Kind -> Kind) -> [Kind] -> [Kind]
    forall a b. (a -> b) -> [a] -> [b]
    map Kind -> Kind
    dropSig
      where
        dropSig :: Type -> Type
        dropSig :: Kind -> Kind
    dropSig (SigT Kind
    t Kind
    k) | [Name] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Kind -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    D.freeVariables Kind
    k) = Kind
    t
        dropSig Kind
    t                                     = Kind
    t

    -- | 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 :: [Kind] -> Kind -> Kind
    quantifyType = Set Name -> [Kind] -> Kind -> Kind
    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 -> [Kind] -> Kind -> Kind
    quantifyType' Set Name
    exclude [Kind]
    c Kind
    t = [TyVarBndr Specificity] -> [Kind] -> Kind -> Kind
    ForallT [TyVarBndr Specificity]
    vs [Kind]
    c Kind
    t
      where
      vs :: [TyVarBndr Specificity]
    vs = (TyVarBndr Specificity -> Bool)
    -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\TyVarBndr Specificity
    tvb -> TyVarBndr Specificity -> Name
    forall flag. TyVarBndr_ flag -> Name
    D.tvName TyVarBndr Specificity
    tvb Name -> Set Name -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.notMember` Set Name
    exclude)
         ([TyVarBndr Specificity] -> [TyVarBndr Specificity])
    -> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
    forall a b. (a -> b) -> a -> b
    $ Specificity -> [TyVarBndr_ ()] -> [TyVarBndr Specificity]
    forall newFlag oldFlag.
    newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
    D.changeTVFlags Specificity
    D.SpecifiedSpec
         ([TyVarBndr_ ()] -> [TyVarBndr Specificity])
    -> [TyVarBndr_ ()] -> [TyVarBndr Specificity]
    forall a b. (a -> b) -> a -> b
    $ [Kind] -> [TyVarBndr_ ()]
    D.freeVariablesWellScoped (Kind
    tKind -> [Kind] -> [Kind]
    forall a. a -> [a] -> [a]
    :[Kind]
    c) -- stable order

    -- | Convert a 'TyVarBndr' into its corresponding 'Type'.
    tvbToType :: D.TyVarBndr_ flag -> Type
    tvbToType :: forall flag. TyVarBndr_ flag -> Kind
    tvbToType = (Name -> Kind) -> (Name -> Kind -> Kind) -> TyVarBndr_ flag -> Kind
    forall r flag.
    (Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
    D.elimTV Name -> Kind
    VarT (Kind -> Kind -> Kind
    SigT (Kind -> Kind -> Kind) -> (Name -> Kind) -> Name -> Kind -> Kind
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Kind
    VarT)

    -- | Peel off a kind signature from a Type (if it has one).
    unSigT :: Type -> Type
    unSigT :: Kind -> Kind
    unSigT (SigT Kind
    t Kind
    _) = Kind
    t
    unSigT Kind
    t          = Kind
    t

    isDataFamily :: D.DatatypeVariant -> Bool
    isDataFamily :: DatatypeVariant -> Bool
    isDataFamily DatatypeVariant
    D.Datatype        = Bool
    False
    isDataFamily DatatypeVariant
    D.Newtype         = Bool
    False
    isDataFamily DatatypeVariant
    D.DataInstance    = Bool
    True
    isDataFamily DatatypeVariant
    D.NewtypeInstance = Bool
    True
    #if MIN_VERSION_th_abstraction(0,5,0)
    isDataFamily DatatypeVariant
    D.TypeData        = Bool
    False
    #endif

    #if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0))
    type TyVarBndrVis = D.TyVarBndr_ ()

    bndrReq :: ()
    bndrReq = ()
    #endif

    ------------------------------------------------------------------------
    -- TH-quoted names
    ------------------------------------------------------------------------
    -- Note that this module only TemplateHaskellQuotes, not TemplateHaskell,
    -- which makes lens able to be used in stage1 cross-compilers.

    traversalTypeName      :: Name
    traversalTypeName :: Name
    traversalTypeName       = ''Traversal

    traversal'TypeName     :: Name
    traversal'TypeName :: Name
    traversal'TypeName      = ''Traversal'

    lensTypeName           :: Name
    lensTypeName :: Name
    lensTypeName            = ''Lens

    lens'TypeName          :: Name
    lens'TypeName :: Name
    lens'TypeName           = ''Lens'

    isoTypeName            :: Name
    isoTypeName :: Name
    isoTypeName             = ''Iso

    iso'TypeName           :: Name
    iso'TypeName :: Name
    iso'TypeName            = ''Iso'

    getterTypeName         :: Name
    getterTypeName :: Name
    getterTypeName          = ''Getter

    foldTypeName           :: Name
    foldTypeName :: Name
    foldTypeName            = ''Fold

    prismTypeName          :: Name
    prismTypeName :: Name
    prismTypeName           = ''Prism

    prism'TypeName         :: Name
    prism'TypeName :: Name
    prism'TypeName          = ''Prism'

    reviewTypeName          :: Name
    reviewTypeName :: Name
    reviewTypeName           = ''Review

    wrappedTypeName         :: Name
    wrappedTypeName :: Name
    wrappedTypeName          = ''Wrapped

    unwrappedTypeName       :: Name
    unwrappedTypeName :: Name
    unwrappedTypeName        = ''Unwrapped

    rewrappedTypeName       :: Name
    rewrappedTypeName :: Name
    rewrappedTypeName        = ''Rewrapped

    _wrapped'ValName        :: Name
    _wrapped'ValName :: Name
    _wrapped'ValName         = '_Wrapped'

    isoValName              :: Name
    isoValName :: Name
    isoValName               = 'iso

    prismValName            :: Name
    prismValName :: Name
    prismValName             = 'prism

    untoValName             :: Name
    untoValName :: Name
    untoValName              = 'unto

    phantomValName          :: Name
    phantomValName :: Name
    phantomValName           = 'phantom2

    phantom2 :: (Functor f, Contravariant f) => f a -> f b
    phantom2 :: forall (f :: * -> *) a b.
    (Functor f, Contravariant f) =>
    f a -> f b
    phantom2 = f a -> f b
    forall (f :: * -> *) a b.
    (Functor f, Contravariant f) =>
    f a -> f b
    phantom
    {-# INLINE phantom2 #-}

    composeValName          :: Name
    composeValName :: Name
    composeValName           = '(.)

    idValName               :: Name
    idValName :: Name
    idValName                = 'id

    fmapValName             :: Name
    fmapValName :: Name
    fmapValName              = 'fmap

    pureValName             :: Name
    pureValName :: Name
    pureValName              = 'pure

    apValName               :: Name
    apValName :: Name
    apValName                = '(<*>)

    rightDataName           :: Name
    rightDataName :: Name
    rightDataName            = 'Right

    leftDataName            :: Name
    leftDataName :: Name
    leftDataName             = 'Left

    ------------------------------------------------------------------------
    -- Support for generating inline pragmas
    ------------------------------------------------------------------------

    inlinePragma :: Name -> [DecQ]
    inlinePragma :: Name -> [DecQ]
    inlinePragma Name
    methodName = [Name -> Inline -> RuleMatch -> Phases -> DecQ
    forall (m :: * -> *).
    Quote m =>
    Name -> Inline -> RuleMatch -> Phases -> m Dec
    pragInlD Name
    methodName Inline
    Inline RuleMatch
    FunLike Phases
    AllPhases]