{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}

#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)
#endif

-- Language.Haskell.TH was not marked as Safe before template-haskell-2.12.0
#if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif

{- |
Module      :  Lens.Micro.TH.Internal
Copyright   :  (C) 2013-2016 Eric Mertens, Edward Kmett; 2018 Monadfix
License     :  BSD-style (see the file LICENSE)

Functions used by "Lens.Micro.TH". This is an internal module and it may go
away or change at any time; do not depend on it.
-}
module Lens.Micro.TH.Internal
(
  -- * Name utilities
  HasName(..),
  newNames,

  -- * Type variable utilities
  HasTypeVars(..),
  typeVars,
  substTypeVars,

  -- * Miscellaneous utilities
  datatypeTypeKinded,
  inlinePragma,
  conAppsT,
  quantifyType, quantifyType',
  tvbToType,
  unSigT,

  -- * Lens functions
  elemOf,
  lengthOf,
  setOf,
  _ForallT,
)
where

import           Data.Monoid
import qualified Data.Map as Map
import           Data.Map (Map)
import qualified Data.Set as Set
import           Data.Set (Set)
import           Data.Maybe
import           Lens.Micro
import           Language.Haskell.TH
import           Language.Haskell.TH.Datatype.TyVarBndr
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative
import           Data.Traversable (traverse)
#endif

-- | Has a 'Name'
class HasName t where
  -- | Extract (or modify) the 'Name' of something
  name :: Lens' t Name

instance HasName (TyVarBndr_ flag) where
  name :: (Name -> f Name) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
name = (Name -> f Name) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
forall (f :: * -> *) flag.
Functor f =>
(Name -> f Name) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
traverseTVName

instance HasName Name where
  name :: (Name -> f Name) -> Name -> f Name
name = (Name -> f Name) -> Name -> f Name
forall a. a -> a
id

-- | On @template-haskell-2.11.0.0@ or later, if a 'GadtC' or 'RecGadtC' has
-- multiple 'Name's, the leftmost 'Name' will be chosen.
instance HasName Con where
  name :: (Name -> f Name) -> Con -> f Con
name Name -> f Name
f (NormalC Name
n [BangType]
tys)       = (Name -> [BangType] -> Con
`NormalC` [BangType]
tys) (Name -> Con) -> f Name -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f Name
n
  name Name -> f Name
f (RecC Name
n [VarBangType]
tys)          = (Name -> [VarBangType] -> Con
`RecC` [VarBangType]
tys) (Name -> Con) -> f Name -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f Name
n
  name Name -> f Name
f (InfixC BangType
l Name
n BangType
r)        = (\Name
n' -> BangType -> Name -> BangType -> Con
InfixC BangType
l Name
n' BangType
r) (Name -> Con) -> f Name -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f Name
n
  name Name -> f Name
f (ForallC [TyVarBndr_ flag]
bds Cxt
ctx Con
con) = [TyVarBndr_ flag] -> Cxt -> Con -> Con
ForallC [TyVarBndr_ flag]
bds Cxt
ctx (Con -> Con) -> f Con -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> f Name) -> Con -> f Con
forall t. HasName t => Lens' t Name
name Name -> f Name
f Con
con
#if MIN_VERSION_template_haskell(2,11,0)
  name Name -> f Name
f (GadtC [Name]
ns [BangType]
argTys Type
retTy) =
    (\Name
n -> [Name] -> [BangType] -> Type -> Con
GadtC [Name
n] [BangType]
argTys Type
retTy) (Name -> Con) -> f Name -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f ([Name] -> Name
forall a. [a] -> a
head [Name]
ns)
  name Name -> f Name
f (RecGadtC [Name]
ns [VarBangType]
argTys Type
retTy) =
    (\Name
n -> [Name] -> [VarBangType] -> Type -> Con
RecGadtC [Name
n] [VarBangType]
argTys Type
retTy) (Name -> Con) -> f Name -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f ([Name] -> Name
forall a. [a] -> a
head [Name]
ns)
#endif

-- | 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)
sequence [ String -> Q 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] ]

-- | Provides for the extraction of free type variables, and alpha renaming.
class HasTypeVars t where
  -- When performing substitution into this traversal you're not allowed
  -- to substitute in a name that is bound internally or you'll violate
  -- the 'Traversal' laws, when in doubt generate your names with 'newName'.
  typeVarsEx :: Set Name -> Traversal' t Name

instance HasTypeVars (TyVarBndr_ flag) where
  typeVarsEx :: Set Name -> Traversal' (TyVarBndr_ flag) Name
typeVarsEx Set Name
s Name -> f Name
f TyVarBndr_ flag
b
    | Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (TyVarBndr_ flag
bTyVarBndr_ flag -> Getting Name (TyVarBndr_ flag) Name -> Name
forall s a. s -> Getting a s a -> a
^.Getting Name (TyVarBndr_ flag) Name
forall t. HasName t => Lens' t Name
name) Set Name
s = TyVarBndr_ flag -> f (TyVarBndr_ flag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndr_ flag
b
    | Bool
otherwise              = (Name -> f Name) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
forall t. HasName t => Lens' t Name
name Name -> f Name
f TyVarBndr_ flag
b

instance HasTypeVars Name where
  typeVarsEx :: Set Name -> Traversal' Name Name
typeVarsEx Set Name
s Name -> f Name
f Name
n
    | Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
n Set Name
s = Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
    | Bool
otherwise      = Name -> f Name
f Name
n

instance HasTypeVars Type where
  typeVarsEx :: Set Name -> Traversal' Type Name
typeVarsEx Set Name
s Name -> f Name
f (VarT Name
n)             = Name -> Type
VarT (Name -> Type) -> f Name -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Name -> f Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Name
n
  typeVarsEx Set Name
s Name -> f Name
f (AppT Type
l Type
r)           = Type -> Type -> Type
AppT (Type -> Type -> Type) -> f Type -> f (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
l f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
r
  typeVarsEx Set Name
s Name -> f Name
f (ForallT [TyVarBndr_ flag]
bs Cxt
ctx Type
ty)  = [TyVarBndr_ flag] -> Cxt -> Type -> Type
ForallT [TyVarBndr_ flag]
bs (Cxt -> Type -> Type) -> f Cxt -> f (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Cxt -> f Cxt
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Cxt
ctx f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Type
ty
       where s' :: Set Name
s' = Set Name
s Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Getting (Endo [Name]) [TyVarBndr_ flag] Name
-> [TyVarBndr_ flag] -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) [TyVarBndr_ flag] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [TyVarBndr_ flag]
bs
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@ConT{}             = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@TupleT{}           = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@ListT{}            = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@ArrowT{}           = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@UnboxedTupleT{}    = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
#if MIN_VERSION_template_haskell(2,8,0)
  typeVarsEx Set Name
s Name -> f Name
f (SigT Type
t Type
k)           = Type -> Type -> Type
SigT (Type -> Type -> Type) -> f Type -> f (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t
                                             f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
k
#else
  typeVarsEx s f (SigT t k)           = (`SigT` k) <$> typeVarsEx s f t
#endif
#if MIN_VERSION_template_haskell(2,8,0)
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@PromotedT{}        = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@PromotedTupleT{}   = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@PromotedNilT{}     = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@PromotedConsT{}    = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@StarT{}            = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@ConstraintT{}      = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@LitT{}             = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
#endif
#if MIN_VERSION_template_haskell(2,10,0)
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@EqualityT{}        = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
#endif
#if MIN_VERSION_template_haskell(2,11,0)
  typeVarsEx Set Name
s Name -> f Name
f (InfixT  Type
t1 Name
n Type
t2)    = Type -> Name -> Type -> Type
InfixT  (Type -> Name -> Type -> Type)
-> f Type -> f (Name -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t1
                                                f (Name -> Type -> Type) -> f Name -> f (Type -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t2
  typeVarsEx Set Name
s Name -> f Name
f (UInfixT Type
t1 Name
n Type
t2)    = Type -> Name -> Type -> Type
UInfixT (Type -> Name -> Type -> Type)
-> f Type -> f (Name -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t1
                                                f (Name -> Type -> Type) -> f Name -> f (Type -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t2
  typeVarsEx Set Name
s Name -> f Name
f (ParensT Type
t)          = Type -> Type
ParensT (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@WildCardT{}        = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
#endif
#if MIN_VERSION_template_haskell(2,12,0)
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Type
t@UnboxedSumT{}      = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
#endif
#if MIN_VERSION_template_haskell(2,15,0)
  typeVarsEx Set Name
s Name -> f Name
f (AppKindT Type
t Type
k)       = Type -> Type -> Type
AppKindT (Type -> Type -> Type) -> f Type -> f (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t
                                                 f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
k
  typeVarsEx Set Name
s Name -> f Name
f (ImplicitParamT String
n Type
t) = String -> Type -> Type
ImplicitParamT String
n (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
t
#endif
#if MIN_VERSION_template_haskell(2,16,0)
  typeVarsEx Set Name
s Name -> f Name
f (ForallVisT [TyVarBndr_ flag]
bs Type
ty)   = [TyVarBndr_ flag] -> Type -> Type
ForallVisT [TyVarBndr_ flag]
bs (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Type
ty
       where s' :: Set Name
s' = Set Name
s Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Getting (Endo [Name]) [TyVarBndr_ flag] Name
-> [TyVarBndr_ flag] -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) [TyVarBndr_ flag] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [TyVarBndr_ flag]
bs
#endif
#if MIN_VERSION_template_haskell(2,17,0)
  typeVarsEx _ _ t@MulArrowT{}        = pure t
#endif

#if !MIN_VERSION_template_haskell(2,10,0)
instance HasTypeVars Pred where
  typeVarsEx s f (ClassP n ts) = ClassP n <$> typeVarsEx s f ts
  typeVarsEx s f (EqualP l r)  = EqualP <$> typeVarsEx s f l <*> typeVarsEx s f r
#endif

instance HasTypeVars Con where
  typeVarsEx :: Set Name -> Traversal' Con Name
typeVarsEx Set Name
s Name -> f Name
f (NormalC Name
n [BangType]
ts) = Name -> [BangType] -> Con
NormalC Name
n ([BangType] -> Con) -> f [BangType] -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BangType -> f BangType) -> [BangType] -> f [BangType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((BangType -> f BangType) -> [BangType] -> f [BangType])
-> ((Type -> f Type) -> BangType -> f BangType)
-> (Type -> f Type)
-> [BangType]
-> f [BangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> f Type) -> BangType -> f BangType
forall s t a b. Field2 s t a b => Lens s t a b
_2) (Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [BangType]
ts
  typeVarsEx Set Name
s Name -> f Name
f (RecC Name
n [VarBangType]
ts) = Name -> [VarBangType] -> Con
RecC Name
n ([VarBangType] -> Con) -> f [VarBangType] -> f Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((VarBangType -> f VarBangType) -> [VarBangType] -> f [VarBangType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((VarBangType -> f VarBangType)
 -> [VarBangType] -> f [VarBangType])
-> ((Type -> f Type) -> VarBangType -> f VarBangType)
-> (Type -> f Type)
-> [VarBangType]
-> f [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> f Type) -> VarBangType -> f VarBangType
forall s t a b. Field3 s t a b => Lens s t a b
_3) (Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [VarBangType]
ts
  typeVarsEx Set Name
s Name -> f Name
f (InfixC BangType
l Name
n BangType
r) = BangType -> Name -> BangType -> Con
InfixC (BangType -> Name -> BangType -> Con)
-> f BangType -> f (Name -> BangType -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BangType -> f BangType
forall b a. HasTypeVars b => (a, b) -> f (a, b)
g BangType
l f (Name -> BangType -> Con) -> f Name -> f (BangType -> Con)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n f (BangType -> Con) -> f BangType -> f Con
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BangType -> f BangType
forall b a. HasTypeVars b => (a, b) -> f (a, b)
g BangType
r
       where g :: (a, b) -> f (a, b)
g (a
i, b
t) = (,) a
i (b -> (a, b)) -> f b -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> b -> f b
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f b
t
  typeVarsEx Set Name
s Name -> f Name
f (ForallC [TyVarBndr_ flag]
bs Cxt
ctx Con
c) = [TyVarBndr_ flag] -> Cxt -> Con -> Con
ForallC [TyVarBndr_ flag]
bs (Cxt -> Con -> Con) -> f Cxt -> f (Con -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> Cxt -> f Cxt
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Cxt
ctx f (Con -> Con) -> f Con -> f Con
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Con -> f Con
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Con
c
       where s' :: Set Name
s' = Set Name
s Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([TyVarBndr_ flag]
bs [TyVarBndr_ flag]
-> Getting (Endo [Name]) [TyVarBndr_ flag] Name -> [Name]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Name]) [TyVarBndr_ flag] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars)
#if MIN_VERSION_template_haskell(2,11,0)
  typeVarsEx Set Name
s Name -> f Name
f (GadtC [Name]
ns [BangType]
argTys Type
retTy) =
    [Name] -> [BangType] -> Type -> Con
GadtC [Name]
ns ([BangType] -> Type -> Con) -> f [BangType] -> f (Type -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BangType -> f BangType) -> [BangType] -> f [BangType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((BangType -> f BangType) -> [BangType] -> f [BangType])
-> ((Type -> f Type) -> BangType -> f BangType)
-> (Type -> f Type)
-> [BangType]
-> f [BangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> f Type) -> BangType -> f BangType
forall s t a b. Field2 s t a b => Lens s t a b
_2) (Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [BangType]
argTys
             f (Type -> Con) -> f Type -> f Con
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
retTy
  typeVarsEx Set Name
s Name -> f Name
f (RecGadtC [Name]
ns [VarBangType]
argTys Type
retTy) =
    [Name] -> [VarBangType] -> Type -> Con
RecGadtC [Name]
ns ([VarBangType] -> Type -> Con)
-> f [VarBangType] -> f (Type -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((VarBangType -> f VarBangType) -> [VarBangType] -> f [VarBangType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((VarBangType -> f VarBangType)
 -> [VarBangType] -> f [VarBangType])
-> ((Type -> f Type) -> VarBangType -> f VarBangType)
-> (Type -> f Type)
-> [VarBangType]
-> f [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> f Type) -> VarBangType -> f VarBangType
forall s t a b. Field3 s t a b => Lens s t a b
_3) (Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [VarBangType]
argTys
                f (Type -> Con) -> f Type -> f Con
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> Type -> f Type
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Type
retTy
#endif

instance HasTypeVars t => HasTypeVars [t] where
  typeVarsEx :: Set Name -> Traversal' [t] Name
typeVarsEx Set Name
s = (t -> f t) -> [t] -> f [t]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((t -> f t) -> [t] -> f [t])
-> ((Name -> f Name) -> t -> f t)
-> (Name -> f Name)
-> [t]
-> f [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Name -> Traversal' t Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s

instance HasTypeVars t => HasTypeVars (Maybe t) where
  typeVarsEx :: Set Name -> Traversal' (Maybe t) Name
typeVarsEx Set Name
s = (t -> f t) -> Maybe t -> f (Maybe t)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((t -> f t) -> Maybe t -> f (Maybe t))
-> ((Name -> f Name) -> t -> f t)
-> (Name -> f Name)
-> Maybe t
-> f (Maybe t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Name -> Traversal' t Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s

-- Traverse /free/ type variables
typeVars :: HasTypeVars t => Traversal' t Name
typeVars :: Traversal' t Name
typeVars = Set Name -> Traversal' t Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
forall a. Monoid a => a
mempty

-- Substitute using a map of names in for /free/ type variables
substTypeVars :: HasTypeVars t => Map Name Name -> t -> t
substTypeVars :: Map Name Name -> t -> t
substTypeVars Map Name Name
m = ASetter t t Name Name -> (Name -> Name) -> t -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter t t Name Name
forall t. HasTypeVars t => Traversal' t Name
typeVars ((Name -> Name) -> t -> t) -> (Name -> Name) -> t -> t
forall a b. (a -> b) -> a -> b
$ \Name
n -> Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
n (Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Name
m)

-- | Generate an INLINE pragma.
inlinePragma :: Name -> [DecQ]
#if MIN_VERSION_template_haskell(2,8,0)
inlinePragma :: Name -> [DecQ]
inlinePragma Name
methodName = [Name -> Inline -> RuleMatch -> Phases -> DecQ
pragInlD Name
methodName Inline
Inline RuleMatch
FunLike Phases
AllPhases]
#else
inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)]
#endif

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

-- 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 -> Type
datatypeTypeKinded DatatypeInfo
di
  = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
di))
  (Cxt -> Type) -> Cxt -> Type
forall a b. (a -> b) -> a -> b
$ Cxt -> Cxt
dropSigsIfNonDataFam
  (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Cxt
D.datatypeInstTypes DatatypeInfo
di
  where
    {-
    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 :: [Type] -> [Type]
    dropSigsIfNonDataFam :: Cxt -> Cxt
dropSigsIfNonDataFam
      | DatatypeVariant -> Bool
isDataFamily (DatatypeInfo -> DatatypeVariant
D.datatypeVariant DatatypeInfo
di) = Cxt -> Cxt
forall a. a -> a
id
      | Bool
otherwise                           = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
dropSig

    dropSig :: Type -> Type
    dropSig :: Type -> Type
dropSig (SigT Type
t Type
k) | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
D.freeVariables Type
k) = Type
t
    dropSig Type
t                                     = Type
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 :: Cxt -> Type -> Type
quantifyType = Set Name -> Cxt -> 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 -> Cxt -> Type -> Type
quantifyType' Set Name
exclude Cxt
c Type
t = [TyVarBndr_ flag] -> Cxt -> Type -> Type
ForallT [TyVarBndr_ flag]
forall flag. [TyVarBndr_ flag]
vs Cxt
c Type
t
  where
  vs :: [TyVarBndr_ flag]
vs = (TyVarBndr_ flag -> Bool) -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVarBndr_ flag
tvb -> TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr_ flag
tvb Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
exclude)
     ([TyVarBndr_ flag] -> [TyVarBndr_ flag])
-> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall a b. (a -> b) -> a -> b
$ Specificity -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
D.changeTVFlags Specificity
D.SpecifiedSpec
     ([TyVarBndr_ flag] -> [TyVarBndr_ flag])
-> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall a b. (a -> b) -> a -> b
$ Cxt -> [TyVarBndr_ flag]
D.freeVariablesWellScoped (Type
tType -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:(Type -> Cxt) -> Cxt -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> Cxt
predTypes Cxt
c) -- stable order

  predTypes :: Pred -> [Type]
#if MIN_VERSION_template_haskell(2,10,0)
  predTypes :: Type -> Cxt
predTypes Type
p = [Type
p]
#else
  predTypes (ClassP _ ts)  = ts
  predTypes (EqualP t1 t2) = [t1, t2]
#endif

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

-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT :: Type -> Type
unSigT (SigT Type
t Type
_) = Type
t
unSigT Type
t          = Type
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

----------------------------------------------------------------------------
-- Lens functions which would've been in Lens.Micro if it wasn't “micro”
----------------------------------------------------------------------------

elemOf :: Eq a => Getting (Endo [a]) s a -> a -> s -> Bool
elemOf :: Getting (Endo [a]) s a -> a -> s -> Bool
elemOf Getting (Endo [a]) s a
l a
x s
s = a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x (s
s s -> Getting (Endo [a]) s a -> [a]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [a]) s a
l)

lengthOf :: Getting (Endo [a]) s a -> s -> Int
lengthOf :: Getting (Endo [a]) s a -> s -> Int
lengthOf Getting (Endo [a]) s a
l s
s = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (s
s s -> Getting (Endo [a]) s a -> [a]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [a]) s a
l)

setOf :: Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf :: Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [a]) s a
l s
s = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList (s
s s -> Getting (Endo [a]) s a -> [a]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [a]) s a
l)

_ForallT :: Traversal' Type ([TyVarBndrSpec], Cxt, Type)
_ForallT :: (([TyVarBndr_ flag], Cxt, Type)
 -> f ([TyVarBndr_ flag], Cxt, Type))
-> Type -> f Type
_ForallT ([TyVarBndr_ flag], Cxt, Type) -> f ([TyVarBndr_ flag], Cxt, Type)
f (ForallT [TyVarBndr_ flag]
a Cxt
b Type
c) = (\([TyVarBndr_ flag]
x, Cxt
y, Type
z) -> [TyVarBndr_ flag] -> Cxt -> Type -> Type
ForallT [TyVarBndr_ flag]
x Cxt
y Type
z) (([TyVarBndr_ flag], Cxt, Type) -> Type)
-> f ([TyVarBndr_ flag], Cxt, Type) -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndr_ flag], Cxt, Type) -> f ([TyVarBndr_ flag], Cxt, Type)
f ([TyVarBndr_ flag]
a, Cxt
b, Type
c)
_ForallT ([TyVarBndr_ flag], Cxt, Type) -> f ([TyVarBndr_ flag], Cxt, Type)
_ Type
other = Type -> f Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
other