{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Language.Haskell.TH.Optics.Internal
  (
  -- * Traversals
    HasTypeVars(..)
  , typeVars      -- :: HasTypeVars t => Traversal' t Name
  , typeVarsKinded
  , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t
  , SubstType(..)

  -- * Prisms
  , _FamilyI
  , _ClosedTypeFamilyD
  , _OpenTypeFamilyD
  , _ForallT

  -- * TyVarBndr compatiblity
  , TyVarBndrSpec
  ) where

import Data.Map as Map hiding (map, toList)
import Data.Maybe (fromMaybe)
import Data.Foldable (traverse_)
import Data.Set as Set hiding (map, toList)
import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr

import Data.Set.Optics
import Optics.Core

-- | 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 = LensVL (TyVarBndr_ flag) (TyVarBndr_ flag) Name Name
-> Lens' (TyVarBndr_ flag) Name
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL (TyVarBndr_ flag) (TyVarBndr_ flag) Name Name
 -> Lens' (TyVarBndr_ flag) Name)
-> LensVL (TyVarBndr_ flag) (TyVarBndr_ flag) Name Name
-> Lens' (TyVarBndr_ flag) Name
forall a b. (a -> b) -> a -> b
$ \Name -> f Name
f -> \case
#if MIN_VERSION_template_haskell(2,17,0)
    PlainTV n flag    -> (\n' -> PlainTV n' flag) <$> f n
    KindedTV n flag k -> (\n' -> KindedTV n' flag k ) <$> f n
#else
    PlainTV n    -> Name -> TyVarBndr_ flag
PlainTV (Name -> TyVarBndr_ flag) -> f Name -> f (TyVarBndr_ flag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f Name
n
    KindedTV n k -> (Name -> Kind -> TyVarBndr_ flag
`KindedTV` Kind
k) (Name -> TyVarBndr_ flag) -> f Name -> f (TyVarBndr_ flag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
f Name
n
#endif

-- | 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 = TraversalVL (TyVarBndr_ flag) (TyVarBndr_ flag) Name Name
-> Traversal' (TyVarBndr_ flag) Name
forall s t a b. TraversalVL s t a b -> Traversal s t a b
traversalVL (TraversalVL (TyVarBndr_ flag) (TyVarBndr_ flag) Name Name
 -> Traversal' (TyVarBndr_ flag) Name)
-> TraversalVL (TyVarBndr_ flag) (TyVarBndr_ flag) Name Name
-> Traversal' (TyVarBndr_ flag) Name
forall a b. (a -> b) -> a -> b
$ \Name -> f Name
f TyVarBndr_ flag
b ->
    if Lens' (TyVarBndr_ flag) Name -> TyVarBndr_ flag -> Name
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' (TyVarBndr_ flag) Name
forall t. HasName t => Lens' t Name
name TyVarBndr_ flag
b Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
s
    then TyVarBndr_ flag -> f (TyVarBndr_ flag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndr_ flag
b
    else Lens' (TyVarBndr_ flag) Name
-> (Name -> f Name) -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf Lens' (TyVarBndr_ flag) Name
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 = TraversalVL Name Name Name Name -> Traversal' Name Name
forall s t a b. TraversalVL s t a b -> Traversal s t a b
traversalVL (TraversalVL Name Name Name Name -> Traversal' Name Name)
-> TraversalVL Name Name Name Name -> Traversal' Name Name
forall a b. (a -> b) -> a -> b
$ \Name -> f Name
f Name
n ->
    if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
s
    then Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
    else Name -> f Name
f Name
n

instance HasTypeVars Type where
  typeVarsEx :: Set Name -> Traversal' Kind Name
typeVarsEx Set Name
s = TraversalVL Kind Kind Name Name -> Traversal' Kind Name
forall s t a b. TraversalVL s t a b -> Traversal s t a b
traversalVL (TraversalVL Kind Kind Name Name -> Traversal' Kind Name)
-> TraversalVL Kind Kind Name Name -> Traversal' Kind Name
forall a b. (a -> b) -> a -> b
$ \Name -> f Name
f -> \case
    VarT n            -> Name -> Kind
VarT (Name -> Kind) -> f Name -> f Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Traversal' Name Name -> (Name -> f Name) -> Name -> f Name
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Name Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s) Name -> f Name
f Name
n
    AppT l 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
<$> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s) Name -> f Name
f Kind
r
    SigT t 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
<$> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s) Name -> f Name
f Kind
k
    ForallT bs ctx ty -> let 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` Optic' A_Traversal NoIx [TyVarBndr_ flag] Name
-> [TyVarBndr_ flag] -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal NoIx [TyVarBndr_ flag] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [TyVarBndr_ flag]
bs
                         in [TyVarBndr_ flag] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr_ flag]
bs (Cxt -> Kind -> Kind) -> f Cxt -> f (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic A_Traversal NoIx Cxt Cxt Name Name
-> (Name -> f Name) -> Cxt -> f Cxt
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Optic A_Traversal NoIx Cxt Cxt Name 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s') Name -> f Name
f Kind
ty
    InfixT  t1 n 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
<$> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                f (Kind -> Kind) -> f Kind -> f Kind
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s) Name -> f Name
f Kind
t2
    UInfixT t1 n 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
<$> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                                 f (Kind -> Kind) -> f Kind -> f Kind
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s) Name -> f Name
f Kind
t2
    ParensT t         -> Kind -> Kind
ParensT (Kind -> Kind) -> f Kind -> f Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s) Name -> f Name
f Kind
t
#if MIN_VERSION_template_haskell(2,15,0)
    AppKindT t 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
<$> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (Set Name -> Traversal' Kind Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s) Name -> f Name
f Kind
k
    ImplicitParamT n 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
<$> Traversal' Kind Name -> (Name -> f Name) -> Kind -> f Kind
forall k (f :: * -> *) (is :: IxList) s t a b.
(Is k A_Traversal, Applicative f) =>
Optic k is s t a b -> (a -> f b) -> s -> f t
traverseOf (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
    Kind
t                 -> Kind -> f Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t

instance HasTypeVars t => HasTypeVars [t] where
  typeVarsEx :: Set Name -> Traversal' [t] Name
typeVarsEx Set Name
s = Traversal [t] [t] t t
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Traversal [t] [t] t t
-> Optic A_Traversal NoIx t t Name Name -> Traversal' [t] Name
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Set Name -> Optic A_Traversal NoIx t t Name Name
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s


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

-- | Traverse /free/ type variables paired with their kinds if applicable.
typeVarsKinded :: Fold Type Type
typeVarsKinded :: Fold Kind Kind
typeVarsKinded = (forall (f :: * -> *).
 Applicative f =>
 (Kind -> f ()) -> Kind -> f ())
-> Fold Kind Kind
forall a u s v.
(forall (f :: * -> *). Applicative f => (a -> f u) -> s -> f v)
-> Fold s a
foldVL ((forall (f :: * -> *).
  Applicative f =>
  (Kind -> f ()) -> Kind -> f ())
 -> Fold Kind Kind)
-> (forall (f :: * -> *).
    Applicative f =>
    (Kind -> f ()) -> Kind -> f ())
-> Fold Kind Kind
forall a b. (a -> b) -> a -> b
$ Set Name -> (Kind -> f ()) -> Kind -> f ()
forall (f :: * -> *).
Applicative f =>
Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
forall a. Monoid a => a
mempty
  where
    go :: Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f = \case
      var :: Kind
var@(VarT Name
n)          -> if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
s then () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else Kind -> f ()
f Kind
var
      var :: Kind
var@(SigT (VarT Name
n) Kind
_) -> if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
s then () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else Kind -> f ()
f Kind
var

      AppT Kind
l Kind
r           -> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
l f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
r
      SigT Kind
t Kind
k           -> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
k
      ForallT [TyVarBndr_ flag]
bs Cxt
ctx Kind
ty  -> let 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` Optic' A_Traversal NoIx [TyVarBndr_ flag] Name
-> [TyVarBndr_ flag] -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal NoIx [TyVarBndr_ flag] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [TyVarBndr_ flag]
bs
                            in (Kind -> f ()) -> Cxt -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s' Kind -> f ()
f) Cxt
ctx f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s' Kind -> f ()
f Kind
ty
      InfixT  Kind
t1 Name
_ Kind
t2    -> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t1 f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t2
      UInfixT Kind
t1 Name
_ Kind
t2    -> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t1 f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t2
      ParensT Kind
t          -> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t
#if MIN_VERSION_template_haskell(2,15,0)
      AppKindT Kind
t Kind
k       -> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
k
      ImplicitParamT String
_ Kind
t -> Set Name -> (Kind -> f ()) -> Kind -> f ()
go Set Name
s Kind -> f ()
f Kind
t
#endif
      Kind
_                 -> () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

-- | Provides substitution for types
class SubstType t where
  -- | Perform substitution for types
  substType :: Map Name Type -> t -> t

instance SubstType Type where
  substType :: Map Name Kind -> Kind -> Kind
substType Map Name Kind
m t :: Kind
t@(VarT Name
n)          = Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Kind
t (Name
n Name -> Map Name Kind -> Maybe Kind
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Name Kind
m)
  substType Map Name Kind
m (ForallT [TyVarBndr_ flag]
bs Cxt
ctx Kind
ty) = [TyVarBndr_ flag] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr_ flag]
bs (Map Name Kind -> Cxt -> Cxt
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m' Cxt
ctx) (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m' Kind
ty)
    where m' :: Map Name Kind
m' = Optic' A_Traversal NoIx [TyVarBndr_ flag] Name
-> (Name -> Map Name Kind -> Map Name Kind)
-> Map Name Kind
-> [TyVarBndr_ flag]
-> Map Name Kind
forall k (is :: IxList) s a r.
Is k A_Fold =>
Optic' k is s a -> (a -> r -> r) -> r -> s -> r
foldrOf Optic' A_Traversal NoIx [TyVarBndr_ flag] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Name -> Map Name Kind -> Map Name Kind
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Map Name Kind
m [TyVarBndr_ flag]
bs
  substType Map Name Kind
m (SigT Kind
t Kind
k)          = Kind -> Kind -> Kind
SigT (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t) (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
k)
  substType Map Name Kind
m (AppT Kind
l Kind
r)          = Kind -> Kind -> Kind
AppT (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
l) (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
r)
  substType Map Name Kind
m (InfixT  Kind
t1 Name
n Kind
t2)   = Kind -> Name -> Kind -> Kind
InfixT  (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t1) Name
n (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t2)
  substType Map Name Kind
m (UInfixT Kind
t1 Name
n Kind
t2)   = Kind -> Name -> Kind -> Kind
UInfixT (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t1) Name
n (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t2)
  substType Map Name Kind
m (ParensT Kind
t)         = Kind -> Kind
ParensT (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t)
#if MIN_VERSION_template_haskell(2,15,0)
  substType Map Name Kind
m (AppKindT Kind
t Kind
k)       = Kind -> Kind -> Kind
AppKindT (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t) (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
k)
  substType Map Name Kind
m (ImplicitParamT String
n Kind
t) = String -> Kind -> Kind
ImplicitParamT String
n (Map Name Kind -> Kind -> Kind
forall t. SubstType t => Map Name Kind -> t -> t
substType Map Name Kind
m Kind
t)
#endif
  substType Map Name Kind
_ Kind
t                   = Kind
t

instance SubstType t => SubstType [t] where
  substType :: Map Name Kind -> [t] -> [t]
substType = (t -> t) -> [t] -> [t]
forall a b. (a -> b) -> [a] -> [b]
map ((t -> t) -> [t] -> [t])
-> (Map Name Kind -> t -> t) -> Map Name Kind -> [t] -> [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name Kind -> t -> t
forall t. SubstType t => Map Name Kind -> t -> t
substType


_FamilyI :: Prism' Info (Dec, [InstanceDec])
_FamilyI :: Prism' Info (Dec, [Dec])
_FamilyI
  = ((Dec, [Dec]) -> Info)
-> (Info -> Maybe (Dec, [Dec])) -> Prism' Info (Dec, [Dec])
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (Dec, [Dec]) -> Info
reviewer Info -> Maybe (Dec, [Dec])
remitter
  where
      reviewer :: (Dec, [Dec]) -> Info
reviewer (Dec
x, [Dec]
y) = Dec -> [Dec] -> Info
FamilyI Dec
x [Dec]
y
      remitter :: Info -> Maybe (Dec, [Dec])
remitter (FamilyI Dec
x [Dec]
y) = (Dec, [Dec]) -> Maybe (Dec, [Dec])
forall a. a -> Maybe a
Just (Dec
x, [Dec]
y)
      remitter Info
_ = Maybe (Dec, [Dec])
forall a. Maybe a
Nothing

_ClosedTypeFamilyD :: Prism' Dec (TypeFamilyHead, [TySynEqn])
_ClosedTypeFamilyD :: Prism' Dec (TypeFamilyHead, [TySynEqn])
_ClosedTypeFamilyD
  = ((TypeFamilyHead, [TySynEqn]) -> Dec)
-> (Dec -> Maybe (TypeFamilyHead, [TySynEqn]))
-> Prism' Dec (TypeFamilyHead, [TySynEqn])
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (TypeFamilyHead, [TySynEqn]) -> Dec
reviewer Dec -> Maybe (TypeFamilyHead, [TySynEqn])
remitter
  where
      reviewer :: (TypeFamilyHead, [TySynEqn]) -> Dec
reviewer (TypeFamilyHead
x, [TySynEqn]
y) = TypeFamilyHead -> [TySynEqn] -> Dec
ClosedTypeFamilyD TypeFamilyHead
x [TySynEqn]
y
      remitter :: Dec -> Maybe (TypeFamilyHead, [TySynEqn])
remitter (ClosedTypeFamilyD TypeFamilyHead
x [TySynEqn]
y) = (TypeFamilyHead, [TySynEqn]) -> Maybe (TypeFamilyHead, [TySynEqn])
forall a. a -> Maybe a
Just (TypeFamilyHead
x, [TySynEqn]
y)
      remitter Dec
_ = Maybe (TypeFamilyHead, [TySynEqn])
forall a. Maybe a
Nothing

_OpenTypeFamilyD :: Prism' Dec TypeFamilyHead
_OpenTypeFamilyD :: Prism' Dec TypeFamilyHead
_OpenTypeFamilyD
  = (TypeFamilyHead -> Dec)
-> (Dec -> Maybe TypeFamilyHead) -> Prism' Dec TypeFamilyHead
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' TypeFamilyHead -> Dec
reviewer Dec -> Maybe TypeFamilyHead
remitter
  where
      reviewer :: TypeFamilyHead -> Dec
reviewer = TypeFamilyHead -> Dec
OpenTypeFamilyD
      remitter :: Dec -> Maybe TypeFamilyHead
remitter (OpenTypeFamilyD TypeFamilyHead
x) = TypeFamilyHead -> Maybe TypeFamilyHead
forall a. a -> Maybe a
Just TypeFamilyHead
x
      remitter Dec
_ = Maybe TypeFamilyHead
forall a. Maybe a
Nothing

_ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type)
_ForallT :: Prism' Kind ([TyVarBndr_ flag], Cxt, Kind)
_ForallT
  = (([TyVarBndr_ flag], Cxt, Kind) -> Kind)
-> (Kind -> Maybe ([TyVarBndr_ flag], Cxt, Kind))
-> Prism' Kind ([TyVarBndr_ flag], Cxt, Kind)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ([TyVarBndr_ flag], Cxt, Kind) -> Kind
reviewer Kind -> Maybe ([TyVarBndr_ flag], Cxt, Kind)
remitter
  where
      reviewer :: ([TyVarBndr_ flag], Cxt, Kind) -> Kind
reviewer ([TyVarBndr_ flag]
x, Cxt
y, Kind
z) = [TyVarBndr_ flag] -> Cxt -> Kind -> Kind
ForallT [TyVarBndr_ flag]
x Cxt
y Kind
z
      remitter :: Kind -> Maybe ([TyVarBndr_ flag], Cxt, Kind)
remitter (ForallT [TyVarBndr_ flag]
x Cxt
y Kind
z) = ([TyVarBndr_ flag], Cxt, Kind)
-> Maybe ([TyVarBndr_ flag], Cxt, Kind)
forall a. a -> Maybe a
Just ([TyVarBndr_ flag]
x, Cxt
y, Kind
z)
      remitter Kind
_ = Maybe ([TyVarBndr_ flag], Cxt, Kind)
forall a. Maybe a
Nothing