{-# 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 :: Lens' (TyVarBndr_ flag) Name
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 :: Lens' Name 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 :: Lens' Con Name
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 Specificity]
bds Cxt
ctx Con
con) = [TyVarBndr Specificity] -> Cxt -> Con -> Con
ForallC [TyVarBndr Specificity]
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
Lens' Con 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 Kind
retTy) =
    (\Name
n -> [Name] -> [BangType] -> Kind -> Con
GadtC [Name
n] [BangType]
argTys Kind
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. HasCallStack => [a] -> a
head [Name]
ns)
  name Name -> f Name
f (RecGadtC [Name]
ns [VarBangType]
argTys Kind
retTy) =
    (\Name
n -> [Name] -> [VarBangType] -> Kind -> Con
RecGadtC [Name
n] [VarBangType]
argTys Kind
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. HasCallStack => [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)
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] ]

-- | 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
Lens' (TyVarBndr_ flag) Name
name) Set Name
s = TyVarBndr_ flag -> f (TyVarBndr_ flag)
forall a. a -> f a
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
Lens' (TyVarBndr_ flag) 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 a. a -> f a
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' Kind Name
typeVarsEx Set Name
s Name -> f Name
f (VarT Name
n)             = Name -> Kind
VarT (Name -> Kind) -> f Name -> f Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Name 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 Kind
l Kind
r)           = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind) -> f Kind -> f (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
l f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
r
  typeVarsEx Set Name
s Name -> f Name
f (ForallT [TyVarBndr Specificity]
bs Cxt
ctx Kind
ty)  = [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
bs (Cxt -> Kind -> Kind) -> f Cxt -> f (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Cxt Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Cxt
ctx f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Kind
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 Specificity] Name
-> [TyVarBndr Specificity] -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) [TyVarBndr Specificity] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [TyVarBndr Specificity] Name
typeVars [TyVarBndr Specificity]
bs
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ConT{}             = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@TupleT{}           = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ListT{}            = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ArrowT{}           = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@UnboxedTupleT{}    = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
#if MIN_VERSION_template_haskell(2,8,0)
  typeVarsEx Set Name
s Name -> f Name
f (SigT Kind
t Kind
k)           = Kind -> Kind -> Kind
SigT (Kind -> Kind -> Kind) -> f Kind -> f (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t
                                             f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
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 :: Kind
t@PromotedT{}        = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@PromotedTupleT{}   = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@PromotedNilT{}     = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@PromotedConsT{}    = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@StarT{}            = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ConstraintT{}      = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@LitT{}             = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
#endif
#if MIN_VERSION_template_haskell(2,10,0)
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@EqualityT{}        = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
#endif
#if MIN_VERSION_template_haskell(2,11,0)
  typeVarsEx Set Name
s Name -> f Name
f (InfixT  Kind
t1 Name
n Kind
t2)    = Kind -> Name -> Kind -> Kind
InfixT  (Kind -> Name -> Kind -> Kind)
-> f Kind -> f (Name -> Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t1
                                                f (Name -> Kind -> Kind) -> f Name -> f (Kind -> Kind)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t2
  typeVarsEx Set Name
s Name -> f Name
f (UInfixT Kind
t1 Name
n Kind
t2)    = Kind -> Name -> Kind -> Kind
UInfixT (Kind -> Name -> Kind -> Kind)
-> f Kind -> f (Name -> Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t1
                                                f (Name -> Kind -> Kind) -> f Name -> f (Kind -> Kind)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t2
  typeVarsEx Set Name
s Name -> f Name
f (ParensT Kind
t)          = Kind -> Kind
ParensT (Kind -> Kind) -> f Kind -> f Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@WildCardT{}        = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
#endif
#if MIN_VERSION_template_haskell(2,12,0)
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@UnboxedSumT{}      = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
#endif
#if MIN_VERSION_template_haskell(2,15,0)
  typeVarsEx Set Name
s Name -> f Name
f (AppKindT Kind
t Kind
k)       = Kind -> Kind -> Kind
AppKindT (Kind -> Kind -> Kind) -> f Kind -> f (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t
                                                 f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
k
  typeVarsEx Set Name
s Name -> f Name
f (ImplicitParamT String
n Kind
t) = String -> Kind -> Kind
ImplicitParamT String
n (Kind -> Kind) -> f Kind -> f Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t
#endif
#if MIN_VERSION_template_haskell(2,16,0)
  typeVarsEx Set Name
s Name -> f Name
f (ForallVisT [TyVarBndr ()]
bs Kind
ty)   = [TyVarBndr ()] -> Kind -> Kind
ForallVisT [TyVarBndr ()]
bs (Kind -> Kind) -> f Kind -> f Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Kind
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 ()] Name
-> [TyVarBndr ()] -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) [TyVarBndr ()] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [TyVarBndr ()] Name
typeVars [TyVarBndr ()]
bs
#endif
#if MIN_VERSION_template_haskell(2,17,0)
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@MulArrowT{}        = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
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
#if MIN_VERSION_template_haskell(2,19,0)
  typeVarsEx Set Name
s Name -> f Name
f (PromotedInfixT  Kind
t1 Name
n Kind
t2) = Kind -> Name -> Kind -> Kind
PromotedInfixT  (Kind -> Name -> Kind -> Kind)
-> f Kind -> f (Name -> Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t1
                                                             f (Name -> Kind -> Kind) -> f Name -> f (Kind -> Kind)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                             f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t2
  typeVarsEx Set Name
s Name -> f Name
f (PromotedUInfixT Kind
t1 Name
n Kind
t2) = Kind -> Name -> Kind -> Kind
PromotedUInfixT (Kind -> Name -> Kind -> Kind)
-> f Kind -> f (Name -> Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t1
                                                             f (Name -> Kind -> Kind) -> f Name -> f (Kind -> Kind)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                             f (Kind -> Kind) -> f Kind -> f Kind
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t2
#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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((BangType -> f BangType) -> [BangType] -> f [BangType])
-> ((Kind -> f Kind) -> BangType -> f BangType)
-> (Kind -> f Kind)
-> [BangType]
-> f [BangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind -> f Kind) -> BangType -> f BangType
forall s t a b. Field2 s t a b => Lens s t a b
Lens BangType BangType Kind Kind
_2) (Set Name -> Traversal' Kind Name
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((VarBangType -> f VarBangType)
 -> [VarBangType] -> f [VarBangType])
-> ((Kind -> f Kind) -> VarBangType -> f VarBangType)
-> (Kind -> f Kind)
-> [VarBangType]
-> f [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind -> f Kind) -> VarBangType -> f VarBangType
forall s t a b. Field3 s t a b => Lens s t a b
Lens VarBangType VarBangType Kind Kind
_3) (Set Name -> Traversal' Kind Name
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 {a} {a}. HasTypeVars a => (a, a) -> f (a, a)
g BangType
l f (Name -> BangType -> Con) -> f Name -> f (BangType -> Con)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n f (BangType -> Con) -> f BangType -> f Con
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BangType -> f BangType
forall {a} {a}. HasTypeVars a => (a, a) -> f (a, a)
g BangType
r
       where g :: (a, a) -> f (a, a)
g (a
i, a
t) = (,) a
i (a -> (a, a)) -> f a -> f (a, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' a Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f a
t
  typeVarsEx Set Name
s Name -> f Name
f (ForallC [TyVarBndr Specificity]
bs Cxt
ctx Con
c) = [TyVarBndr Specificity] -> Cxt -> Con -> Con
ForallC [TyVarBndr Specificity]
bs (Cxt -> Con -> Con) -> f Cxt -> f (Con -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> Traversal' Cxt Name
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 a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Con Name
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 Specificity]
bs [TyVarBndr Specificity]
-> Getting (Endo [Name]) [TyVarBndr Specificity] Name -> [Name]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Name]) [TyVarBndr Specificity] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [TyVarBndr Specificity] Name
typeVars)
#if MIN_VERSION_template_haskell(2,11,0)
  typeVarsEx Set Name
s Name -> f Name
f (GadtC [Name]
ns [BangType]
argTys Kind
retTy) =
    [Name] -> [BangType] -> Kind -> Con
GadtC [Name]
ns ([BangType] -> Kind -> Con) -> f [BangType] -> f (Kind -> 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((BangType -> f BangType) -> [BangType] -> f [BangType])
-> ((Kind -> f Kind) -> BangType -> f BangType)
-> (Kind -> f Kind)
-> [BangType]
-> f [BangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind -> f Kind) -> BangType -> f BangType
forall s t a b. Field2 s t a b => Lens s t a b
Lens BangType BangType Kind Kind
_2) (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [BangType]
argTys
             f (Kind -> Con) -> f Kind -> f Con
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
retTy
  typeVarsEx Set Name
s Name -> f Name
f (RecGadtC [Name]
ns [VarBangType]
argTys Kind
retTy) =
    [Name] -> [VarBangType] -> Kind -> Con
RecGadtC [Name]
ns ([VarBangType] -> Kind -> Con)
-> f [VarBangType] -> f (Kind -> 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((VarBangType -> f VarBangType)
 -> [VarBangType] -> f [VarBangType])
-> ((Kind -> f Kind) -> VarBangType -> f VarBangType)
-> (Kind -> f Kind)
-> [VarBangType]
-> f [VarBangType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind -> f Kind) -> VarBangType -> f VarBangType
forall s t a b. Field3 s t a b => Lens s t a b
Lens VarBangType VarBangType Kind Kind
_3) (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [VarBangType]
argTys
                f (Kind -> Con) -> f Kind -> f Con
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe 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 :: forall t. HasTypeVars t => 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 :: forall t. HasTypeVars t => 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
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
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
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 -> Kind
conAppsT Name
conName = (Kind -> Kind -> Kind) -> Kind -> Cxt -> 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)

-- 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 -> Cxt -> 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))
  (Cxt -> Kind) -> Cxt -> Kind
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                           = (Kind -> Kind) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Kind
dropSig

    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 :: Cxt -> Kind -> Kind
quantifyType = Set Name -> Cxt -> 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 -> Cxt -> Kind -> Kind
quantifyType' Set Name
exclude Cxt
c Kind
t = [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
vs Cxt
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
$ Cxt -> [TyVarBndr ()]
D.freeVariablesWellScoped (Kind
tKind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:(Kind -> Cxt) -> Cxt -> Cxt
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Kind -> Cxt
predTypes Cxt
c) -- stable order

  predTypes :: Pred -> [Type]
#if MIN_VERSION_template_haskell(2,10,0)
  predTypes :: Kind -> Cxt
predTypes Kind
p = [Kind
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 :: 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

----------------------------------------------------------------------------
-- 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 :: forall a s. Eq a => Getting (Endo [a]) s a -> a -> s -> Bool
elemOf Getting (Endo [a]) s a
l a
x s
s = a -> [a] -> Bool
forall a. Eq a => 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 :: forall a s. Getting (Endo [a]) s a -> s -> Int
lengthOf Getting (Endo [a]) s a
l s
s = [a] -> Int
forall a. [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 :: forall a s. Ord a => 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 :: Traversal' Kind ([TyVarBndr Specificity], Cxt, Kind)
_ForallT ([TyVarBndr Specificity], Cxt, Kind)
-> f ([TyVarBndr Specificity], Cxt, Kind)
f (ForallT [TyVarBndr Specificity]
a Cxt
b Kind
c) = (\([TyVarBndr Specificity]
x, Cxt
y, Kind
z) -> [TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr Specificity]
x Cxt
y Kind
z) (([TyVarBndr Specificity], Cxt, Kind) -> Kind)
-> f ([TyVarBndr Specificity], Cxt, Kind) -> f Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndr Specificity], Cxt, Kind)
-> f ([TyVarBndr Specificity], Cxt, Kind)
f ([TyVarBndr Specificity]
a, Cxt
b, Kind
c)
_ForallT ([TyVarBndr Specificity], Cxt, Kind)
-> f ([TyVarBndr Specificity], Cxt, Kind)
_ Kind
other = Kind -> f Kind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
other