{-# 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 = forall (f :: * -> *) flag.
Functor f =>
(Name -> f Name) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
traverseTVName

instance HasName Name where
  name :: Lens' Name Name
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) 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) 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) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 Kind
retTy) =
    (\Name
n -> [Name] -> [BangType] -> Kind -> Con
GadtC [Name
n] [BangType]
argTys Kind
retTy) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f (forall a. [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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f (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 = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ forall (m :: * -> *). Quote m => String -> m Name
newName (String
baseforall a. [a] -> [a] -> [a]
++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
    | forall a. Ord a => a -> Set a -> Bool
Set.member (TyVarBndr_ flag
bforall s a. s -> Getting a s a -> a
^.forall t. HasName t => Lens' t Name
name) Set Name
s = forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndr_ flag
b
    | Bool
otherwise              = 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
    | forall a. Ord a => a -> Set a -> Bool
Set.member Name
n Set Name
s = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Cxt
ctx forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars [TyVarBndr Specificity]
bs
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ConT{}             = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@TupleT{}           = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ListT{}            = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ArrowT{}           = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@UnboxedTupleT{}    = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t
                                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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{}        = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@PromotedTupleT{}   = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@PromotedNilT{}     = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@PromotedConsT{}    = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@StarT{}            = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@ConstraintT{}      = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@LitT{}             = 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{}        = 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  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t1
                                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t1
                                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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{}        = 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{}      = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f Kind
t
                                                 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars [TyVarBndr ()]
bs
#endif
#if MIN_VERSION_template_haskell(2,17,0)
  typeVarsEx Set Name
_ Name -> f Name
_ t :: Kind
t@MulArrowT{}        = 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 s f (PromotedInfixT  t1 n t2) = PromotedInfixT  <$> typeVarsEx s f t1
                                                             <*> pure n
                                                             <*> typeVarsEx s f t2
  typeVarsEx s f (PromotedUInfixT t1 n t2) = PromotedUInfixT <$> typeVarsEx s f t1
                                                             <*> pure n
                                                             <*> typeVarsEx s f 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
_3) (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {a}. HasTypeVars a => (a, a) -> f (a, a)
g BangType
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f Cxt
ctx forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a. Ord a => [a] -> Set a
Set.fromList ([TyVarBndr Specificity]
bs forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. 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 Kind
retTy) =
    [Name] -> [BangType] -> Kind -> Con
GadtC [Name]
ns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) (forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [BangType]
argTys
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
_3) (forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s Name -> f Name
f) [VarBangType]
argTys
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx 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 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall t. HasTypeVars t => Traversal' t Name
typeVars forall a b. (a -> b) -> a -> b
$ \Name
n -> forall a. a -> Maybe a -> a
fromMaybe Name
n (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 = [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 = 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
  = 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))
  forall a b. (a -> b) -> a -> b
$ Cxt -> Cxt
dropSigsIfNonDataFam
  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) = forall a. a -> a
id
      | Bool
otherwise                           = forall a b. (a -> b) -> [a] -> [b]
map Kind -> Kind
dropSig

    dropSig :: Type -> Type
    dropSig :: Kind -> Kind
dropSig (SigT Kind
t Kind
k) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (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' 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVarBndr Specificity
tvb -> forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr Specificity
tvb forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
exclude)
     forall a b. (a -> b) -> a -> b
$ forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
D.changeTVFlags Specificity
D.SpecifiedSpec
     forall a b. (a -> b) -> a -> b
$ Cxt -> [TyVarBndr ()]
D.freeVariablesWellScoped (Kind
tforall a. a -> [a] -> [a]
: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 = forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
D.elimTV Name -> Kind
VarT (Kind -> Kind -> Kind
SigT 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 = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x (s
s 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length (s
s 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 = forall a. Ord a => [a] -> Set a
Set.fromList (s
s 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) 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
other