{-# OPTIONS -Wall -fno-warn-unused-binds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Language.Haskell.TH.ExpandSyns(-- * Expand synonyms
                                      expandSyns
                                     ,expandSynsWith
                                     ,SynonymExpansionSettings
                                     ,noWarnTypeFamilies

                                      -- * Misc utilities
                                     ,substInType
                                     ,substInCon
                                     ,evades,evade) where

import Language.Haskell.TH.ExpandSyns.SemigroupCompat as Sem
import Language.Haskell.TH hiding(cxt)
import qualified Data.Set as Set
import Data.Generics
import Data.Maybe
import Control.Monad
import Prelude

-- For ghci
#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(X,Y,Z) 1
#endif

packagename :: String
packagename :: String
packagename = String
"th-expand-syns"

#if !MIN_VERSION_template_haskell(2,4,0)
type TyVarBndr = Name
type Pred = Type
#endif

#if MIN_VERSION_template_haskell(2,17,0)
tyVarBndrGetName :: TyVarBndr a -> Name
tyVarBndrGetName (PlainTV n _) = n
tyVarBndrGetName (KindedTV n _ _) = n
#elif MIN_VERSION_template_haskell(2,4,0)
tyVarBndrGetName :: TyVarBndr -> Name
tyVarBndrGetName :: TyVarBndr -> Name
tyVarBndrGetName (PlainTV Name
n) = Name
n
tyVarBndrGetName (KindedTV Name
n Kind
_) = Name
n
#else
tyVarBndrGetName = id
#endif

#if MIN_VERSION_template_haskell(2,17,0)
tyVarBndrSetName :: Name -> TyVarBndr a -> TyVarBndr a
tyVarBndrSetName n (PlainTV _ f) = PlainTV n f
tyVarBndrSetName n (KindedTV _ f k) = KindedTV n f k
#elif MIN_VERSION_template_haskell(2,4,0)
tyVarBndrSetName :: Name -> TyVarBndr -> TyVarBndr
tyVarBndrSetName :: Name -> TyVarBndr -> TyVarBndr
tyVarBndrSetName Name
n (PlainTV Name
_) = Name -> TyVarBndr
PlainTV Name
n
tyVarBndrSetName Name
n (KindedTV Name
_ Kind
k) = Name -> Kind -> TyVarBndr
KindedTV Name
n Kind
k
#else
tyVarBndrSetName n _ = n
#endif

#if MIN_VERSION_template_haskell(2,10,0)
-- mapPred is not needed for template-haskell >= 2.10
#elif MIN_VERSION_template_haskell(2,4,0)
mapPred :: (Type -> Type) -> Pred -> Pred
mapPred f (ClassP n ts) = ClassP n (f <$> ts)
mapPred f (EqualP t1 t2) = EqualP (f t1) (f t2)
#else
mapPred = id
#endif

#if MIN_VERSION_template_haskell(2,10,0)
bindPred :: (Type -> Q Type) -> Pred -> Q Pred
bindPred :: (Kind -> Q Kind) -> Kind -> Q Kind
bindPred = (Kind -> Q Kind) -> Kind -> Q Kind
forall a. a -> a
id
#elif MIN_VERSION_template_haskell(2,4,0)
bindPred :: (Type -> Q Type) -> Pred -> Q Pred
bindPred f (ClassP n ts) = ClassP n <$> mapM f ts
bindPred f (EqualP t1 t2) = EqualP <$> f t1 <*> f t2
#else
bindPred = id
#endif

#if __GLASGOW_HASKELL__ < 709
(<$>) :: (Functor f) => (a -> b) -> f a -> f b
(<$>) = fmap
#endif
(<*>) :: (Monad m) => m (a -> b) -> m a -> m b
<*> :: m (a -> b) -> m a -> m b
(<*>) = m (a -> b) -> m a -> m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap



data SynonymExpansionSettings =
  SynonymExpansionSettings {
    SynonymExpansionSettings -> Bool
sesWarnTypeFamilies :: Bool
  }


instance Semigroup SynonymExpansionSettings where
  SynonymExpansionSettings Bool
w1 <> :: SynonymExpansionSettings
-> SynonymExpansionSettings -> SynonymExpansionSettings
<> SynonymExpansionSettings Bool
w2 =
    Bool -> SynonymExpansionSettings
SynonymExpansionSettings (Bool
w1 Bool -> Bool -> Bool
&& Bool
w2)

-- | Default settings ('mempty'):
--
-- * Warn if type families are encountered.
--
-- (The 'mappend' is currently rather useless; the monoid instance is intended for additional settings in the future).
instance Monoid SynonymExpansionSettings where
  mempty :: SynonymExpansionSettings
mempty =
    SynonymExpansionSettings :: Bool -> SynonymExpansionSettings
SynonymExpansionSettings {
      sesWarnTypeFamilies :: Bool
sesWarnTypeFamilies = Bool
True
    }

#if !MIN_VERSION_base(4,11,0)
-- starting with base-4.11, mappend definitions are redundant;
-- at some point `mappend` will be removed from `Monoid`
  mappend = (Sem.<>)
#endif


-- | Suppresses the warning that type families are unsupported.
noWarnTypeFamilies :: SynonymExpansionSettings
noWarnTypeFamilies :: SynonymExpansionSettings
noWarnTypeFamilies = SynonymExpansionSettings
forall a. Monoid a => a
mempty { sesWarnTypeFamilies :: Bool
sesWarnTypeFamilies = Bool
False }

warn ::  String -> Q ()
warn :: String -> Q ()
warn String
msg =
#if MIN_VERSION_template_haskell(2,8,0)
    String -> Q ()
reportWarning
#else
    report False
#endif
      (String
packagename String -> String -> String
forall a. [a] -> [a] -> [a]
++String
": WARNING: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msg)




type SynInfo = ([Name],Type)

nameIsSyn :: SynonymExpansionSettings -> Name -> Q (Maybe SynInfo)
nameIsSyn :: SynonymExpansionSettings -> Name -> Q (Maybe SynInfo)
nameIsSyn SynonymExpansionSettings
settings Name
n = do
  Info
i <- Name -> Q Info
reify Name
n
  case Info
i of
    ClassI {} -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    ClassOpI {} -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    TyConI Dec
d -> SynonymExpansionSettings -> Dec -> Q (Maybe SynInfo)
decIsSyn SynonymExpansionSettings
settings Dec
d
#if MIN_VERSION_template_haskell(2,7,0)
    FamilyI Dec
d [Dec]
_ -> SynonymExpansionSettings -> Dec -> Q (Maybe SynInfo)
decIsSyn SynonymExpansionSettings
settings Dec
d -- Called for warnings
#endif
    PrimTyConI {} -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    DataConI {} -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    VarI {} -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    TyVarI {} -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#if MIN_VERSION_template_haskell(2,12,0)
    PatSynI {} -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

  where
    no :: m (Maybe a)
no = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

decIsSyn :: SynonymExpansionSettings -> Dec -> Q (Maybe SynInfo)
decIsSyn :: SynonymExpansionSettings -> Dec -> Q (Maybe SynInfo)
decIsSyn SynonymExpansionSettings
settings = Dec -> Q (Maybe SynInfo)
go
  where
    go :: Dec -> Q (Maybe SynInfo)
go (TySynD Name
_ [TyVarBndr]
vars Kind
t) = Maybe SynInfo -> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (SynInfo -> Maybe SynInfo
forall a. a -> Maybe a
Just (TyVarBndr -> Name
tyVarBndrGetName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
vars,Kind
t))

#if MIN_VERSION_template_haskell(2,11,0)
    go (OpenTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr]
_ FamilyResultSig
_ Maybe InjectivityAnn
_)) = SynonymExpansionSettings -> Name -> Q ()
maybeWarnTypeFamily SynonymExpansionSettings
settings Name
name Q () -> Q (Maybe SynInfo) -> Q (Maybe SynInfo)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (ClosedTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) = SynonymExpansionSettings -> Name -> Q ()
maybeWarnTypeFamily SynonymExpansionSettings
settings Name
name Q () -> Q (Maybe SynInfo) -> Q (Maybe SynInfo)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#else

#if MIN_VERSION_template_haskell(2,9,0)
    go (ClosedTypeFamilyD name _ _ _) = maybeWarnTypeFamily settings name >> no
#endif

    go (FamilyD TypeFam name _ _) = maybeWarnTypeFamily settings name >> no
#endif

    go (FunD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (ValD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (DataD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (NewtypeD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (ClassD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (InstanceD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (SigD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (ForeignD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no

#if MIN_VERSION_template_haskell(2,8,0)
    go (InfixD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

#if MIN_VERSION_template_haskell(2,4,0)
    go (PragmaD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

    -- Nothing to expand for data families, so no warning
#if MIN_VERSION_template_haskell(2,11,0)
    go (DataFamilyD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#elif MIN_VERSION_template_haskell(2,4,0)
    go (FamilyD DataFam _ _ _) = no
#endif

#if MIN_VERSION_template_haskell(2,4,0)
    go (DataInstD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (NewtypeInstD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (TySynInstD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

#if MIN_VERSION_template_haskell(2,9,0)
    go (RoleAnnotD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

#if MIN_VERSION_template_haskell(2,10,0)
    go (StandaloneDerivD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (DefaultSigD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

#if MIN_VERSION_template_haskell(2,12,0)
    go (PatSynD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
    go (PatSynSigD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

#if MIN_VERSION_template_haskell(2,15,0)
    go (ImplicitParamBindD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

#if MIN_VERSION_template_haskell(2,16,0)
    go (KiSigD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#endif

    no :: m (Maybe a)
no = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

#if MIN_VERSION_template_haskell(2,4,0)
maybeWarnTypeFamily :: SynonymExpansionSettings -> Name -> Q ()
maybeWarnTypeFamily :: SynonymExpansionSettings -> Name -> Q ()
maybeWarnTypeFamily SynonymExpansionSettings
settings Name
name =
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SynonymExpansionSettings -> Bool
sesWarnTypeFamilies SynonymExpansionSettings
settings) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
      String -> Q ()
warn (String
"Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Name -> String
forall a. Show a => a -> String
show Name
name)
#endif







-- | Calls 'expandSynsWith' with the default settings.
expandSyns :: Type -> Q Type
expandSyns :: Kind -> Q Kind
expandSyns = SynonymExpansionSettings -> Kind -> Q Kind
expandSynsWith SynonymExpansionSettings
forall a. Monoid a => a
mempty


-- | Expands all type synonyms in the given type. Type families currently won't be expanded (but will be passed through).
expandSynsWith :: SynonymExpansionSettings -> Type -> Q Type
expandSynsWith :: SynonymExpansionSettings -> Kind -> Q Kind
expandSynsWith SynonymExpansionSettings
settings = Kind -> Q Kind
expandSyns'

    where
      expandSyns' :: Kind -> Q Kind
expandSyns' Kind
t =
         do
           ([TypeArg]
acc,Kind
t') <- [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go [] Kind
t
           Kind -> Q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return ((Kind -> TypeArg -> Kind) -> Kind -> [TypeArg] -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> TypeArg -> Kind
applyTypeArg Kind
t' [TypeArg]
acc)

#if MIN_VERSION_template_haskell(2,4,0)
      expandKindSyns' :: Kind -> Q Kind
expandKindSyns' Kind
k =
# if MIN_VERSION_template_haskell(2,8,0)
         do
           ([TypeArg]
acc,Kind
k') <- [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go [] Kind
k
           Kind -> Q Kind
forall (m :: * -> *) a. Monad m => a -> m a
return ((Kind -> TypeArg -> Kind) -> Kind -> [TypeArg] -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> TypeArg -> Kind
applyTypeArg Kind
k' [TypeArg]
acc)
# else
         return k -- No kind variables on old versions of GHC
# endif
#endif

      applyTypeArg :: Type -> TypeArg -> Type
      applyTypeArg :: Kind -> TypeArg -> Kind
applyTypeArg Kind
f (TANormal Kind
x) = Kind
f Kind -> Kind -> Kind
`AppT` Kind
x
      applyTypeArg Kind
f (TyArg Kind
_x)   =
#if __GLASGOW_HASKELL__ >= 807
                                    Kind
f Kind -> Kind -> Kind
`AppKindT` Kind
_x
#else
                                    -- VKA isn't supported, so
                                    -- conservatively drop the argument
                                    f
#endif


      -- Filter the normal type arguments from a list of TypeArgs.
      filterTANormals :: [TypeArg] -> [Type]
      filterTANormals :: [TypeArg] -> [Kind]
filterTANormals = (TypeArg -> Maybe Kind) -> [TypeArg] -> [Kind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TypeArg -> Maybe Kind
getTANormal
        where
          getTANormal :: TypeArg -> Maybe Type
          getTANormal :: TypeArg -> Maybe Kind
getTANormal (TANormal Kind
t) = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
t
          getTANormal (TyArg {})   = Maybe Kind
forall a. Maybe a
Nothing

      -- Must only be called on an `x' requiring no expansion
      passThrough :: a -> b -> m (a, b)
passThrough a
acc b
x = (a, b) -> m (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
acc, b
x)

      forallAppError :: [TypeArg] -> Type -> Q a
      forallAppError :: [TypeArg] -> Kind -> Q a
forallAppError [TypeArg]
acc Kind
x =
          String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
packagenameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": Unexpected application of the local quantification: "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++Kind -> String
forall a. Show a => a -> String
show Kind
x
                String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n    (to the arguments "String -> String -> String
forall a. [a] -> [a] -> [a]
++[TypeArg] -> String
forall a. Show a => a -> String
show [TypeArg]
accString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")")

      -- If @go args t = (args', t')@,
      --
      -- Precondition:
      --  All elements of `args' are expanded.
      -- Postcondition:
      --  All elements of `args'' and `t'' are expanded.
      --  `t' applied to `args' equals `t'' applied to `args'' (up to expansion, of course)

      go :: [TypeArg] -> Type -> Q ([TypeArg], Type)

      go :: [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go [TypeArg]
acc x :: Kind
x@Kind
ListT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@Kind
ArrowT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@(TupleT Int
_) = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@(VarT Name
_) = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x

      go [] (ForallT [TyVarBndr]
ns [Kind]
cxt Kind
t) = do
        [Kind]
cxt' <- (Kind -> Q Kind) -> [Kind] -> Q [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Kind -> Q Kind) -> Kind -> Q Kind
bindPred Kind -> Q Kind
expandSyns') [Kind]
cxt
        Kind
t' <- Kind -> Q Kind
expandSyns' Kind
t
        ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TyVarBndr] -> [Kind] -> Kind -> Kind
ForallT [TyVarBndr]
ns [Kind]
cxt' Kind
t')

      go [TypeArg]
acc x :: Kind
x@ForallT{} = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall a. [TypeArg] -> Kind -> Q a
forallAppError [TypeArg]
acc Kind
x

      go [TypeArg]
acc (AppT Kind
t1 Kind
t2) =
          do
            Kind
r <- Kind -> Q Kind
expandSyns' Kind
t2
            [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go (Kind -> TypeArg
TANormal Kind
rTypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
acc) Kind
t1

      go [TypeArg]
acc x :: Kind
x@(ConT Name
n) =
          do
            Maybe SynInfo
i <- SynonymExpansionSettings -> Name -> Q (Maybe SynInfo)
nameIsSyn SynonymExpansionSettings
settings Name
n
            case Maybe SynInfo
i of
              Maybe SynInfo
Nothing -> ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc, Kind
x)
              Just ([Name]
vars,Kind
body) ->
                  if [TypeArg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeArg]
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
vars
                  then String -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
packagenameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": expandSynsWith: Underapplied type synonym: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Name, [TypeArg]) -> String
forall a. Show a => a -> String
show(Name
n,[TypeArg]
acc))
                  else
                      let
                          substs :: [(Name, Kind)]
substs = [Name] -> [Kind] -> [(Name, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vars ([TypeArg] -> [Kind]
filterTANormals [TypeArg]
acc)
                          expanded :: Kind
expanded = [(Name, Kind)] -> Kind -> Kind
forall a. SubstTypeVariable a => [(Name, Kind)] -> a -> a
doSubsts [(Name, Kind)]
substs Kind
body
                      in
                        [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go (Int -> [TypeArg] -> [TypeArg]
forall a. Int -> [a] -> [a]
drop ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
vars) [TypeArg]
acc) Kind
expanded


#if MIN_VERSION_template_haskell(2,4,0)
      go [TypeArg]
acc (SigT Kind
t Kind
kind) =
          do
            ([TypeArg]
acc',Kind
t') <- [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go [TypeArg]
acc Kind
t
            Kind
kind' <- Kind -> Q Kind
expandKindSyns' Kind
kind
            ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc', Kind -> Kind -> Kind
SigT Kind
t' Kind
kind')
#endif

#if MIN_VERSION_template_haskell(2,6,0)
      go [TypeArg]
acc x :: Kind
x@(UnboxedTupleT Int
_) = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
#endif

#if MIN_VERSION_template_haskell(2,8,0)
      go [TypeArg]
acc x :: Kind
x@(PromotedT Name
_) = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@(PromotedTupleT Int
_) = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@Kind
PromotedConsT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@Kind
PromotedNilT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@Kind
StarT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@Kind
ConstraintT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
      go [TypeArg]
acc x :: Kind
x@(LitT TyLit
_) = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
#endif

#if MIN_VERSION_template_haskell(2,10,0)
      go [TypeArg]
acc x :: Kind
x@Kind
EqualityT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
#endif

#if MIN_VERSION_template_haskell(2,11,0)
      go [TypeArg]
acc (InfixT Kind
t1 Name
nm Kind
t2) =
          do
            Kind
t1' <- Kind -> Q Kind
expandSyns' Kind
t1
            Kind
t2' <- Kind -> Q Kind
expandSyns' Kind
t2
            ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc,Kind -> Name -> Kind -> Kind
InfixT Kind
t1' Name
nm Kind
t2')
      go [TypeArg]
acc (UInfixT Kind
t1 Name
nm Kind
t2) =
          do
            Kind
t1' <- Kind -> Q Kind
expandSyns' Kind
t1
            Kind
t2' <- Kind -> Q Kind
expandSyns' Kind
t2
            ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc,Kind -> Name -> Kind -> Kind
UInfixT Kind
t1' Name
nm Kind
t2')
      go [TypeArg]
acc (ParensT Kind
t) =
          do
            ([TypeArg]
acc',Kind
t') <- [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go [TypeArg]
acc Kind
t
            ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc',Kind -> Kind
ParensT Kind
t')
      go [TypeArg]
acc x :: Kind
x@Kind
WildCardT = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
#endif

#if MIN_VERSION_template_haskell(2,12,0)
      go [TypeArg]
acc x :: Kind
x@(UnboxedSumT Int
_) = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Kind
x
#endif

#if MIN_VERSION_template_haskell(2,15,0)
      go [TypeArg]
acc (AppKindT Kind
t Kind
k) =
          do
            Kind
k' <- Kind -> Q Kind
expandKindSyns' Kind
k
            [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go (Kind -> TypeArg
TyArg Kind
k'TypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
acc) Kind
t
      go [TypeArg]
acc (ImplicitParamT String
n Kind
t) =
          do
            ([TypeArg]
acc',Kind
t') <- [TypeArg] -> Kind -> Q ([TypeArg], Kind)
go [TypeArg]
acc Kind
t
            ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc',String -> Kind -> Kind
ImplicitParamT String
n Kind
t')
#endif

#if MIN_VERSION_template_haskell(2,16,0)
      go [] (ForallVisT [TyVarBndr]
ns Kind
t) = do
        Kind
t' <- Kind -> Q Kind
expandSyns' Kind
t
        ([TypeArg], Kind) -> Q ([TypeArg], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TyVarBndr] -> Kind -> Kind
ForallVisT [TyVarBndr]
ns Kind
t')

      go [TypeArg]
acc x :: Kind
x@ForallVisT{} = [TypeArg] -> Kind -> Q ([TypeArg], Kind)
forall a. [TypeArg] -> Kind -> Q a
forallAppError [TypeArg]
acc Kind
x
#endif

#if MIN_VERSION_template_haskell(2,17,0)
      go acc x@MulArrowT = passThrough acc x
#endif

-- | An argument to a type, either a normal type ('TANormal') or a visible
-- kind application ('TyArg').
data TypeArg
  = TANormal Type -- Normal arguments
  | TyArg    Kind -- Visible kind applications
  deriving Int -> TypeArg -> String -> String
[TypeArg] -> String -> String
TypeArg -> String
(Int -> TypeArg -> String -> String)
-> (TypeArg -> String)
-> ([TypeArg] -> String -> String)
-> Show TypeArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TypeArg] -> String -> String
$cshowList :: [TypeArg] -> String -> String
show :: TypeArg -> String
$cshow :: TypeArg -> String
showsPrec :: Int -> TypeArg -> String -> String
$cshowsPrec :: Int -> TypeArg -> String -> String
Show

class SubstTypeVariable a where
    -- | Capture-free substitution
    subst :: (Name, Type) -> a -> a



instance SubstTypeVariable Type where
  subst :: (Name, Kind) -> Kind -> Kind
subst vt :: (Name, Kind)
vt@(Name
v, Kind
t) = Kind -> Kind
go
    where
      go :: Kind -> Kind
go (AppT Kind
x Kind
y) = Kind -> Kind -> Kind
AppT (Kind -> Kind
go Kind
x) (Kind -> Kind
go Kind
y)
      go s :: Kind
s@(ConT Name
_) = Kind
s
      go s :: Kind
s@(VarT Name
w) | Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
w = Kind
t
                    | Bool
otherwise = Kind
s
      go Kind
ArrowT = Kind
ArrowT
      go Kind
ListT = Kind
ListT
      go (ForallT [TyVarBndr]
vars [Kind]
cxt Kind
body) =
          (Name, Kind)
-> [TyVarBndr] -> ([(Name, Kind)] -> [TyVarBndr] -> Kind) -> Kind
forall a.
(Name, Kind)
-> [TyVarBndr] -> ([(Name, Kind)] -> [TyVarBndr] -> a) -> a
commonForallCase (Name, Kind)
vt [TyVarBndr]
vars (([(Name, Kind)] -> [TyVarBndr] -> Kind) -> Kind)
-> ([(Name, Kind)] -> [TyVarBndr] -> Kind) -> Kind
forall a b. (a -> b) -> a -> b
$ \[(Name, Kind)]
vts' [TyVarBndr]
vars' ->
          [TyVarBndr] -> [Kind] -> Kind -> Kind
ForallT [TyVarBndr]
vars' ((Kind -> Kind) -> [Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Kind)] -> Kind -> Kind
forall a. SubstTypeVariable a => [(Name, Kind)] -> a -> a
doSubsts [(Name, Kind)]
vts') [Kind]
cxt) ([(Name, Kind)] -> Kind -> Kind
forall a. SubstTypeVariable a => [(Name, Kind)] -> a -> a
doSubsts [(Name, Kind)]
vts' Kind
body)

      go s :: Kind
s@(TupleT Int
_) = Kind
s

#if MIN_VERSION_template_haskell(2,4,0)
      go (SigT Kind
t1 Kind
kind) = Kind -> Kind -> Kind
SigT (Kind -> Kind
go Kind
t1) ((Name, Kind) -> Kind -> Kind
forall a. SubstTypeVariable a => (Name, Kind) -> a -> a
subst (Name, Kind)
vt Kind
kind)
#endif

#if MIN_VERSION_template_haskell(2,6,0)
      go s :: Kind
s@(UnboxedTupleT Int
_) = Kind
s
#endif

#if MIN_VERSION_template_haskell(2,8,0)
      go s :: Kind
s@(PromotedT Name
_) = Kind
s
      go s :: Kind
s@(PromotedTupleT Int
_) = Kind
s
      go s :: Kind
s@Kind
PromotedConsT = Kind
s
      go s :: Kind
s@Kind
PromotedNilT = Kind
s
      go s :: Kind
s@Kind
StarT = Kind
s
      go s :: Kind
s@Kind
ConstraintT = Kind
s
      go s :: Kind
s@(LitT TyLit
_) = Kind
s
#endif

#if MIN_VERSION_template_haskell(2,10,0)
      go s :: Kind
s@Kind
EqualityT = Kind
s
#endif

#if MIN_VERSION_template_haskell(2,11,0)
      go (InfixT Kind
t1 Name
nm Kind
t2) = Kind -> Name -> Kind -> Kind
InfixT (Kind -> Kind
go Kind
t1) Name
nm (Kind -> Kind
go Kind
t2)
      go (UInfixT Kind
t1 Name
nm Kind
t2) = Kind -> Name -> Kind -> Kind
UInfixT (Kind -> Kind
go Kind
t1) Name
nm (Kind -> Kind
go Kind
t2)
      go (ParensT Kind
t1) = Kind -> Kind
ParensT (Kind -> Kind
go Kind
t1)
      go s :: Kind
s@Kind
WildCardT = Kind
s
#endif

#if MIN_VERSION_template_haskell(2,12,0)
      go s :: Kind
s@(UnboxedSumT Int
_) = Kind
s
#endif

#if MIN_VERSION_template_haskell(2,15,0)
      go (AppKindT Kind
ty Kind
ki) = Kind -> Kind -> Kind
AppKindT (Kind -> Kind
go Kind
ty) (Kind -> Kind
go Kind
ki)
      go (ImplicitParamT String
n Kind
ty) = String -> Kind -> Kind
ImplicitParamT String
n (Kind -> Kind
go Kind
ty)
#endif

#if MIN_VERSION_template_haskell(2,16,0)
      go (ForallVisT [TyVarBndr]
vars Kind
body) =
          (Name, Kind)
-> [TyVarBndr] -> ([(Name, Kind)] -> [TyVarBndr] -> Kind) -> Kind
forall a.
(Name, Kind)
-> [TyVarBndr] -> ([(Name, Kind)] -> [TyVarBndr] -> a) -> a
commonForallCase (Name, Kind)
vt [TyVarBndr]
vars (([(Name, Kind)] -> [TyVarBndr] -> Kind) -> Kind)
-> ([(Name, Kind)] -> [TyVarBndr] -> Kind) -> Kind
forall a b. (a -> b) -> a -> b
$ \[(Name, Kind)]
vts' [TyVarBndr]
vars' ->
          [TyVarBndr] -> Kind -> Kind
ForallVisT [TyVarBndr]
vars' ([(Name, Kind)] -> Kind -> Kind
forall a. SubstTypeVariable a => [(Name, Kind)] -> a -> a
doSubsts [(Name, Kind)]
vts' Kind
body)
#endif

#if MIN_VERSION_template_haskell(2,17,0)
      go MulArrowT = MulArrowT
#endif

-- testCapture :: Type
-- testCapture =
--     let
--         n = mkName
--         v = VarT . mkName
--     in
--       substInType (n "x", v "y" `AppT` v "z")
--                   (ForallT
--                    [n "y",n "z"]
--                    [ConT (mkName "Show") `AppT` v "x" `AppT` v "z"]
--                    (v "x" `AppT` v "y"))


#if MIN_VERSION_template_haskell(2,4,0) && !MIN_VERSION_template_haskell(2,10,0)
instance SubstTypeVariable Pred where
    subst s = mapPred (subst s)
#endif

#if MIN_VERSION_template_haskell(2,4,0) && !MIN_VERSION_template_haskell(2,8,0)
instance SubstTypeVariable Kind where
    subst _ = id -- No kind variables on old versions of GHC
#endif

-- | Make a name (based on the first arg) that's distinct from every name in the second arg
--
-- Example why this is necessary:
--
-- > type E x = forall y. Either x y
-- >
-- > ... expandSyns [t| forall y. y -> E y |]
--
-- The example as given may actually work correctly without any special capture-avoidance depending
-- on how GHC handles the @y@s, but in any case, the input type to expandSyns may be an explicit
-- AST using 'mkName' to ensure a collision.
--
evade :: Data d => Name -> d -> Name
evade :: Name -> d -> Name
evade Name
n d
t =
    let
        vars :: Set.Set Name
        vars :: Set Name
vars = (Set Name -> Set Name -> Set Name)
-> GenericQ (Set Name) -> d -> Set Name
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Set Name -> (Name -> Set Name) -> a -> Set Name
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Set Name
forall a. Set a
Set.empty Name -> Set Name
forall a. a -> Set a
Set.singleton) d
t

        go :: Name -> Name
go Name
n1 = if Name
n1 Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
vars
                then Name -> Name
go (Name -> Name
bump Name
n1)
                else Name
n1

        bump :: Name -> Name
bump = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'f'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
    in
      Name -> Name
go Name
n

-- | Make a list of names (based on the first arg) such that every name in the result
-- is distinct from every name in the second arg, and from the other results
evades :: (Data t) => [Name] -> t -> [Name]
evades :: [Name] -> t -> [Name]
evades [Name]
ns t
t = (Name -> [Name] -> [Name]) -> [Name] -> [Name] -> [Name]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Name -> [Name] -> [Name]
c [] [Name]
ns
    where
      c :: Name -> [Name] -> [Name]
c Name
n [Name]
rec = Name -> ([Name], t) -> Name
forall d. Data d => Name -> d -> Name
evade Name
n ([Name]
rec,t
t) Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
rec

-- evadeTest = let v = mkName "x"
--             in
--               evade v (AppT (VarT v) (VarT (mkName "fx")))

instance SubstTypeVariable Con where
  subst :: (Name, Kind) -> Con -> Con
subst (Name, Kind)
vt = Con -> Con
go
    where
      st :: a -> a
st = (Name, Kind) -> a -> a
forall a. SubstTypeVariable a => (Name, Kind) -> a -> a
subst (Name, Kind)
vt

      go :: Con -> Con
go (NormalC Name
n [BangType]
ts) = Name -> [BangType] -> Con
NormalC Name
n [(Bang
x, Kind -> Kind
forall a. SubstTypeVariable a => a -> a
st Kind
y) | (Bang
x,Kind
y) <- [BangType]
ts]
      go (RecC Name
n [VarBangType]
ts) = Name -> [VarBangType] -> Con
RecC Name
n [(Name
x, Bang
y, Kind -> Kind
forall a. SubstTypeVariable a => a -> a
st Kind
z) | (Name
x,Bang
y,Kind
z) <- [VarBangType]
ts]
      go (InfixC (Bang
y1,Kind
t1) Name
op (Bang
y2,Kind
t2)) = BangType -> Name -> BangType -> Con
InfixC (Bang
y1,Kind -> Kind
forall a. SubstTypeVariable a => a -> a
st Kind
t1) Name
op (Bang
y2,Kind -> Kind
forall a. SubstTypeVariable a => a -> a
st Kind
t2)
      go (ForallC [TyVarBndr]
vars [Kind]
cxt Con
body) =
          (Name, Kind)
-> [TyVarBndr] -> ([(Name, Kind)] -> [TyVarBndr] -> Con) -> Con
forall a.
(Name, Kind)
-> [TyVarBndr] -> ([(Name, Kind)] -> [TyVarBndr] -> a) -> a
commonForallCase (Name, Kind)
vt [TyVarBndr]
vars (([(Name, Kind)] -> [TyVarBndr] -> Con) -> Con)
-> ([(Name, Kind)] -> [TyVarBndr] -> Con) -> Con
forall a b. (a -> b) -> a -> b
$ \[(Name, Kind)]
vts' [TyVarBndr]
vars' ->
          [TyVarBndr] -> [Kind] -> Con -> Con
ForallC [TyVarBndr]
vars' ((Kind -> Kind) -> [Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Kind)] -> Kind -> Kind
forall a. SubstTypeVariable a => [(Name, Kind)] -> a -> a
doSubsts [(Name, Kind)]
vts') [Kind]
cxt) ([(Name, Kind)] -> Con -> Con
forall a. SubstTypeVariable a => [(Name, Kind)] -> a -> a
doSubsts [(Name, Kind)]
vts' Con
body)
#if MIN_VERSION_template_haskell(2,11,0)
      go c :: Con
c@GadtC{} = Con -> Con
forall a a. Ppr a => a -> a
errGadt Con
c
      go c :: Con
c@RecGadtC{} = Con -> Con
forall a a. Ppr a => a -> a
errGadt Con
c

      errGadt :: a -> a
errGadt a
c = String -> a
forall a. HasCallStack => String -> a
error (String
packagenameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": substInCon currently doesn't support GADT constructors with GHC >= 8 ("String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Ppr a => a -> String
pprint a
cString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")")
#endif


class HasForallConstruct a where
#if MIN_VERSION_template_haskell(2,17,0)
    mkForall :: [TyVarBndrSpec] -> Cxt -> a -> a
#else
    mkForall :: [TyVarBndr] -> Cxt -> a -> a
#endif

instance HasForallConstruct Type where
    mkForall :: [TyVarBndr] -> [Kind] -> Kind -> Kind
mkForall = [TyVarBndr] -> [Kind] -> Kind -> Kind
ForallT

instance HasForallConstruct Con where
    mkForall :: [TyVarBndr] -> [Kind] -> Con -> Con
mkForall = [TyVarBndr] -> [Kind] -> Con -> Con
ForallC



-- Apply a substitution to something underneath a @forall@. The continuation
-- argument provides new substitutions and fresh type variable binders to avoid
-- the outer substitution from capturing the thing underneath the @forall@.
#if MIN_VERSION_template_haskell(2,17,0)
commonForallCase :: (Name, Type) -> [TyVarBndr flag]
                 -> ([(Name, Type)] -> [TyVarBndr flag] -> a)
                 -> a
#else
commonForallCase :: (Name, Type) -> [TyVarBndr]
                 -> ([(Name, Type)] -> [TyVarBndr] -> a)
                 -> a
#endif
commonForallCase :: (Name, Kind)
-> [TyVarBndr] -> ([(Name, Kind)] -> [TyVarBndr] -> a) -> a
commonForallCase vt :: (Name, Kind)
vt@(Name
v,Kind
t) [TyVarBndr]
bndrs [(Name, Kind)] -> [TyVarBndr] -> a
k
            -- If a variable with the same name as the one to be replaced is bound by the forall,
            -- the variable to be replaced is shadowed in the body, so we leave the whole thing alone (no recursion)
          | Name
v Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TyVarBndr -> Name
tyVarBndrGetName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
bndrs) = [(Name, Kind)] -> [TyVarBndr] -> a
k [(Name, Kind)
vt] [TyVarBndr]
bndrs

          | Bool
otherwise =
              let
                  -- prevent capture
                  vars :: [Name]
vars = TyVarBndr -> Name
tyVarBndrGetName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
bndrs
                  freshes :: [Name]
freshes = [Name] -> Kind -> [Name]
forall t. Data t => [Name] -> t -> [Name]
evades [Name]
vars Kind
t
                  freshTyVarBndrs :: [TyVarBndr]
freshTyVarBndrs = (Name -> TyVarBndr -> TyVarBndr)
-> [Name] -> [TyVarBndr] -> [TyVarBndr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> TyVarBndr -> TyVarBndr
tyVarBndrSetName [Name]
freshes [TyVarBndr]
bndrs
                  substs :: [(Name, Kind)]
substs = [Name] -> [Kind] -> [(Name, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vars (Name -> Kind
VarT (Name -> Kind) -> [Name] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
freshes)
              in
                [(Name, Kind)] -> [TyVarBndr] -> a
k ((Name, Kind)
vt(Name, Kind) -> [(Name, Kind)] -> [(Name, Kind)]
forall a. a -> [a] -> [a]
:[(Name, Kind)]
substs) [TyVarBndr]
freshTyVarBndrs

-- Apply multiple substitutions.
doSubsts :: SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts :: [(Name, Kind)] -> a -> a
doSubsts [(Name, Kind)]
substs a
x = ((Name, Kind) -> a -> a) -> a -> [(Name, Kind)] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, Kind) -> a -> a
forall a. SubstTypeVariable a => (Name, Kind) -> a -> a
subst a
x [(Name, Kind)]
substs

-- | Capture-free substitution
substInType :: (Name,Type) -> Type -> Type
substInType :: (Name, Kind) -> Kind -> Kind
substInType = (Name, Kind) -> Kind -> Kind
forall a. SubstTypeVariable a => (Name, Kind) -> a -> a
subst

-- | Capture-free substitution
substInCon :: (Name,Type) -> Con -> Con
substInCon :: (Name, Kind) -> Con -> Con
substInCon = (Name, Kind) -> Con -> Con
forall a. SubstTypeVariable a => (Name, Kind) -> a -> a
subst