{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Language.Haskell.TH.ExpandSyns(
expandSyns
,expandSynsWith
,SynonymExpansionSettings
,noWarnTypeFamilies
,substInType
,substInCon
,evades,evade) where
import Language.Haskell.TH.Datatype.TyVarBndr
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
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
#endif
#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(X,Y,Z) 1
#endif
packagename :: String
packagename :: String
packagename = String
"th-expand-syns"
tyVarBndrSetName :: Name -> TyVarBndr_ flag -> TyVarBndr_ flag
tyVarBndrSetName :: Name -> TyVarBndr_ flag -> TyVarBndr_ flag
tyVarBndrSetName Name
n = (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
mapTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
n)
#if MIN_VERSION_template_haskell(2,10,0)
#else
mapPred :: (Type -> Type) -> Pred -> Pred
mapPred f (ClassP n ts) = ClassP n (f <$> ts)
mapPred f (EqualP t1 t2) = EqualP (f t1) (f t2)
#endif
#if MIN_VERSION_template_haskell(2,10,0)
bindPred :: (Type -> Q Type) -> Pred -> Q Pred
bindPred :: (Type -> Q Type) -> Type -> Q Type
bindPred = (Type -> Q Type) -> Type -> Q Type
forall a. a -> a
id
#else
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) `ap` f t2
#endif
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)
instance Monoid SynonymExpansionSettings where
mempty :: SynonymExpansionSettings
mempty =
SynonymExpansionSettings :: Bool -> SynonymExpansionSettings
SynonymExpansionSettings {
sesWarnTypeFamilies :: Bool
sesWarnTypeFamilies = Bool
True
}
#if !MIN_VERSION_base(4,11,0)
mappend = (Sem.<>)
#endif
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
#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_ flag]
vars Type
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_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr_ flag]
vars,Type
t))
#if MIN_VERSION_template_haskell(2,11,0)
go (OpenTypeFamilyD (TypeFamilyHead Name
name [TyVarBndr_ flag]
_ 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_ flag]
_ 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
go (PragmaD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#if MIN_VERSION_template_haskell(2,11,0)
go (DataFamilyD {}) = Q (Maybe SynInfo)
forall (m :: * -> *) a. Monad m => m (Maybe a)
no
#else
go (FamilyD DataFam _ _ _) = no
#endif
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
#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
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)
expandSyns :: Type -> Q Type
expandSyns :: Type -> Q Type
expandSyns = SynonymExpansionSettings -> Type -> Q Type
expandSynsWith SynonymExpansionSettings
forall a. Monoid a => a
mempty
expandSynsWith :: SynonymExpansionSettings -> Type -> Q Type
expandSynsWith :: SynonymExpansionSettings -> Type -> Q Type
expandSynsWith SynonymExpansionSettings
settings = Type -> Q Type
expandSyns'
where
expandSyns' :: Type -> Q Type
expandSyns' Type
t =
do
([TypeArg]
acc,Type
t') <- [TypeArg] -> Type -> Q ([TypeArg], Type)
go [] Type
t
Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> TypeArg -> Type) -> Type -> [TypeArg] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> TypeArg -> Type
applyTypeArg Type
t' [TypeArg]
acc)
expandKindSyns' :: Type -> Q Type
expandKindSyns' Type
k =
#if MIN_VERSION_template_haskell(2,8,0)
do
([TypeArg]
acc,Type
k') <- [TypeArg] -> Type -> Q ([TypeArg], Type)
go [] Type
k
Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> TypeArg -> Type) -> Type -> [TypeArg] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> TypeArg -> Type
applyTypeArg Type
k' [TypeArg]
acc)
#else
return k
#endif
applyTypeArg :: Type -> TypeArg -> Type
applyTypeArg :: Type -> TypeArg -> Type
applyTypeArg Type
f (TANormal Type
x) = Type
f Type -> Type -> Type
`AppT` Type
x
applyTypeArg Type
f (TyArg Type
_x) =
#if __GLASGOW_HASKELL__ >= 807
Type
f Type -> Type -> Type
`AppKindT` Type
_x
#else
f
#endif
filterTANormals :: [TypeArg] -> [Type]
filterTANormals :: [TypeArg] -> [Type]
filterTANormals = (TypeArg -> Maybe Type) -> [TypeArg] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TypeArg -> Maybe Type
getTANormal
where
getTANormal :: TypeArg -> Maybe Type
getTANormal :: TypeArg -> Maybe Type
getTANormal (TANormal Type
t) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
getTANormal (TyArg {}) = Maybe Type
forall a. Maybe a
Nothing
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] -> Type -> Q a
forallAppError [TypeArg]
acc Type
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]
++Type -> String
forall a. Show a => a -> String
show Type
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
")")
go :: [TypeArg] -> Type -> Q ([TypeArg], Type)
go :: [TypeArg] -> Type -> Q ([TypeArg], Type)
go [TypeArg]
acc x :: Type
x@Type
ListT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@Type
ArrowT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@(TupleT Int
_) = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@(VarT Name
_) = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [] (ForallT [TyVarBndr_ flag]
ns [Type]
cxt Type
t) = do
[Type]
cxt' <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Q Type) -> Type -> Q Type
bindPred Type -> Q Type
expandSyns') [Type]
cxt
Type
t' <- Type -> Q Type
expandSyns' Type
t
([TypeArg], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TyVarBndr_ flag] -> [Type] -> Type -> Type
ForallT [TyVarBndr_ flag]
ns [Type]
cxt' Type
t')
go [TypeArg]
acc x :: Type
x@ForallT{} = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall a. [TypeArg] -> Type -> Q a
forallAppError [TypeArg]
acc Type
x
go [TypeArg]
acc (AppT Type
t1 Type
t2) =
do
Type
r <- Type -> Q Type
expandSyns' Type
t2
[TypeArg] -> Type -> Q ([TypeArg], Type)
go (Type -> TypeArg
TANormal Type
rTypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
acc) Type
t1
go [TypeArg]
acc x :: Type
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], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc, Type
x)
Just ([Name]
vars,Type
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], Type)
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, Type)]
substs = [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vars ([TypeArg] -> [Type]
filterTANormals [TypeArg]
acc)
expanded :: Type
expanded = [(Name, Type)] -> Type -> Type
forall a. SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts [(Name, Type)]
substs Type
body
in
[TypeArg] -> Type -> Q ([TypeArg], Type)
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) Type
expanded
go [TypeArg]
acc (SigT Type
t Type
kind) =
do
([TypeArg]
acc',Type
t') <- [TypeArg] -> Type -> Q ([TypeArg], Type)
go [TypeArg]
acc Type
t
Type
kind' <- Type -> Q Type
expandKindSyns' Type
kind
([TypeArg], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc', Type -> Type -> Type
SigT Type
t' Type
kind')
#if MIN_VERSION_template_haskell(2,6,0)
go [TypeArg]
acc x :: Type
x@(UnboxedTupleT Int
_) = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
#endif
#if MIN_VERSION_template_haskell(2,8,0)
go [TypeArg]
acc x :: Type
x@(PromotedT Name
_) = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@(PromotedTupleT Int
_) = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@Type
PromotedConsT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@Type
PromotedNilT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@Type
StarT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@Type
ConstraintT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
go [TypeArg]
acc x :: Type
x@(LitT TyLit
_) = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
#endif
#if MIN_VERSION_template_haskell(2,10,0)
go [TypeArg]
acc x :: Type
x@Type
EqualityT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
#endif
#if MIN_VERSION_template_haskell(2,11,0)
go [TypeArg]
acc (InfixT Type
t1 Name
nm Type
t2) =
do
Type
t1' <- Type -> Q Type
expandSyns' Type
t1
Type
t2' <- Type -> Q Type
expandSyns' Type
t2
([TypeArg], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc,Type -> Name -> Type -> Type
InfixT Type
t1' Name
nm Type
t2')
go [TypeArg]
acc (UInfixT Type
t1 Name
nm Type
t2) =
do
Type
t1' <- Type -> Q Type
expandSyns' Type
t1
Type
t2' <- Type -> Q Type
expandSyns' Type
t2
([TypeArg], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc,Type -> Name -> Type -> Type
UInfixT Type
t1' Name
nm Type
t2')
go [TypeArg]
acc (ParensT Type
t) =
do
([TypeArg]
acc',Type
t') <- [TypeArg] -> Type -> Q ([TypeArg], Type)
go [TypeArg]
acc Type
t
([TypeArg], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc',Type -> Type
ParensT Type
t')
go [TypeArg]
acc x :: Type
x@Type
WildCardT = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
#endif
#if MIN_VERSION_template_haskell(2,12,0)
go [TypeArg]
acc x :: Type
x@(UnboxedSumT Int
_) = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall (m :: * -> *) a b. Monad m => a -> b -> m (a, b)
passThrough [TypeArg]
acc Type
x
#endif
#if MIN_VERSION_template_haskell(2,15,0)
go [TypeArg]
acc (AppKindT Type
t Type
k) =
do
Type
k' <- Type -> Q Type
expandKindSyns' Type
k
[TypeArg] -> Type -> Q ([TypeArg], Type)
go (Type -> TypeArg
TyArg Type
k'TypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
acc) Type
t
go [TypeArg]
acc (ImplicitParamT String
n Type
t) =
do
([TypeArg]
acc',Type
t') <- [TypeArg] -> Type -> Q ([TypeArg], Type)
go [TypeArg]
acc Type
t
([TypeArg], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeArg]
acc',String -> Type -> Type
ImplicitParamT String
n Type
t')
#endif
#if MIN_VERSION_template_haskell(2,16,0)
go [] (ForallVisT [TyVarBndr_ flag]
ns Type
t) = do
Type
t' <- Type -> Q Type
expandSyns' Type
t
([TypeArg], Type) -> Q ([TypeArg], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TyVarBndr_ flag] -> Type -> Type
ForallVisT [TyVarBndr_ flag]
ns Type
t')
go [TypeArg]
acc x :: Type
x@ForallVisT{} = [TypeArg] -> Type -> Q ([TypeArg], Type)
forall a. [TypeArg] -> Type -> Q a
forallAppError [TypeArg]
acc Type
x
#endif
#if MIN_VERSION_template_haskell(2,17,0)
go acc x@MulArrowT = passThrough acc x
#endif
data TypeArg
= TANormal Type
| TyArg Kind
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
subst :: (Name, Type) -> a -> a
instance SubstTypeVariable Type where
subst :: (Name, Type) -> Type -> Type
subst vt :: (Name, Type)
vt@(Name
v, Type
t) = Type -> Type
go
where
go :: Type -> Type
go (AppT Type
x Type
y) = Type -> Type -> Type
AppT (Type -> Type
go Type
x) (Type -> Type
go Type
y)
go s :: Type
s@(ConT Name
_) = Type
s
go s :: Type
s@(VarT Name
w) | Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
w = Type
t
| Bool
otherwise = Type
s
go Type
ArrowT = Type
ArrowT
go Type
ListT = Type
ListT
go (ForallT [TyVarBndr_ flag]
vars [Type]
cxt Type
body) =
(Name, Type)
-> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> Type)
-> Type
forall flag a.
(Name, Type)
-> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> a)
-> a
commonForallCase (Name, Type)
vt [TyVarBndr_ flag]
vars (([(Name, Type)] -> [TyVarBndr_ flag] -> Type) -> Type)
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> Type) -> Type
forall a b. (a -> b) -> a -> b
$ \[(Name, Type)]
vts' [TyVarBndr_ flag]
vars' ->
[TyVarBndr_ flag] -> [Type] -> Type -> Type
ForallT [TyVarBndr_ flag]
vars' ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Type)] -> Type -> Type
forall a. SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts [(Name, Type)]
vts') [Type]
cxt) ([(Name, Type)] -> Type -> Type
forall a. SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts [(Name, Type)]
vts' Type
body)
go s :: Type
s@(TupleT Int
_) = Type
s
go (SigT Type
t1 Type
kind) = Type -> Type -> Type
SigT (Type -> Type
go Type
t1) ((Name, Type) -> Type -> Type
forall a. SubstTypeVariable a => (Name, Type) -> a -> a
subst (Name, Type)
vt Type
kind)
#if MIN_VERSION_template_haskell(2,6,0)
go s :: Type
s@(UnboxedTupleT Int
_) = Type
s
#endif
#if MIN_VERSION_template_haskell(2,8,0)
go s :: Type
s@(PromotedT Name
_) = Type
s
go s :: Type
s@(PromotedTupleT Int
_) = Type
s
go s :: Type
s@Type
PromotedConsT = Type
s
go s :: Type
s@Type
PromotedNilT = Type
s
go s :: Type
s@Type
StarT = Type
s
go s :: Type
s@Type
ConstraintT = Type
s
go s :: Type
s@(LitT TyLit
_) = Type
s
#endif
#if MIN_VERSION_template_haskell(2,10,0)
go s :: Type
s@Type
EqualityT = Type
s
#endif
#if MIN_VERSION_template_haskell(2,11,0)
go (InfixT Type
t1 Name
nm Type
t2) = Type -> Name -> Type -> Type
InfixT (Type -> Type
go Type
t1) Name
nm (Type -> Type
go Type
t2)
go (UInfixT Type
t1 Name
nm Type
t2) = Type -> Name -> Type -> Type
UInfixT (Type -> Type
go Type
t1) Name
nm (Type -> Type
go Type
t2)
go (ParensT Type
t1) = Type -> Type
ParensT (Type -> Type
go Type
t1)
go s :: Type
s@Type
WildCardT = Type
s
#endif
#if MIN_VERSION_template_haskell(2,12,0)
go s :: Type
s@(UnboxedSumT Int
_) = Type
s
#endif
#if MIN_VERSION_template_haskell(2,15,0)
go (AppKindT Type
ty Type
ki) = Type -> Type -> Type
AppKindT (Type -> Type
go Type
ty) (Type -> Type
go Type
ki)
go (ImplicitParamT String
n Type
ty) = String -> Type -> Type
ImplicitParamT String
n (Type -> Type
go Type
ty)
#endif
#if MIN_VERSION_template_haskell(2,16,0)
go (ForallVisT [TyVarBndr_ flag]
vars Type
body) =
(Name, Type)
-> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> Type)
-> Type
forall flag a.
(Name, Type)
-> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> a)
-> a
commonForallCase (Name, Type)
vt [TyVarBndr_ flag]
vars (([(Name, Type)] -> [TyVarBndr_ flag] -> Type) -> Type)
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> Type) -> Type
forall a b. (a -> b) -> a -> b
$ \[(Name, Type)]
vts' [TyVarBndr_ flag]
vars' ->
[TyVarBndr_ flag] -> Type -> Type
ForallVisT [TyVarBndr_ flag]
vars' ([(Name, Type)] -> Type -> Type
forall a. SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts [(Name, Type)]
vts' Type
body)
#endif
#if MIN_VERSION_template_haskell(2,17,0)
go MulArrowT = MulArrowT
#endif
#if !MIN_VERSION_template_haskell(2,10,0)
instance SubstTypeVariable Pred where
subst s = mapPred (subst s)
#endif
#if !MIN_VERSION_template_haskell(2,8,0)
instance SubstTypeVariable Kind where
subst _ = id
#endif
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
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
instance SubstTypeVariable Con where
subst :: (Name, Type) -> Con -> Con
subst (Name, Type)
vt = Con -> Con
go
where
st :: a -> a
st = (Name, Type) -> a -> a
forall a. SubstTypeVariable a => (Name, Type) -> a -> a
subst (Name, Type)
vt
go :: Con -> Con
go (NormalC Name
n [BangType]
ts) = Name -> [BangType] -> Con
NormalC Name
n [(Bang
x, Type -> Type
forall a. SubstTypeVariable a => a -> a
st Type
y) | (Bang
x,Type
y) <- [BangType]
ts]
go (RecC Name
n [VarBangType]
ts) = Name -> [VarBangType] -> Con
RecC Name
n [(Name
x, Bang
y, Type -> Type
forall a. SubstTypeVariable a => a -> a
st Type
z) | (Name
x,Bang
y,Type
z) <- [VarBangType]
ts]
go (InfixC (Bang
y1,Type
t1) Name
op (Bang
y2,Type
t2)) = BangType -> Name -> BangType -> Con
InfixC (Bang
y1,Type -> Type
forall a. SubstTypeVariable a => a -> a
st Type
t1) Name
op (Bang
y2,Type -> Type
forall a. SubstTypeVariable a => a -> a
st Type
t2)
go (ForallC [TyVarBndr_ flag]
vars [Type]
cxt Con
body) =
(Name, Type)
-> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> Con)
-> Con
forall flag a.
(Name, Type)
-> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> a)
-> a
commonForallCase (Name, Type)
vt [TyVarBndr_ flag]
vars (([(Name, Type)] -> [TyVarBndr_ flag] -> Con) -> Con)
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> Con) -> Con
forall a b. (a -> b) -> a -> b
$ \[(Name, Type)]
vts' [TyVarBndr_ flag]
vars' ->
[TyVarBndr_ flag] -> [Type] -> Con -> Con
ForallC [TyVarBndr_ flag]
vars' ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Type)] -> Type -> Type
forall a. SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts [(Name, Type)]
vts') [Type]
cxt) ([(Name, Type)] -> Con -> Con
forall a. SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts [(Name, Type)]
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
commonForallCase :: (Name, Type) -> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> a)
-> a
commonForallCase :: (Name, Type)
-> [TyVarBndr_ flag]
-> ([(Name, Type)] -> [TyVarBndr_ flag] -> a)
-> a
commonForallCase vt :: (Name, Type)
vt@(Name
v,Type
t) [TyVarBndr_ flag]
bndrs [(Name, Type)] -> [TyVarBndr_ flag] -> a
k
| Name
v Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr_ flag]
bndrs) = [(Name, Type)] -> [TyVarBndr_ flag] -> a
k [(Name, Type)
vt] [TyVarBndr_ flag]
bndrs
| Bool
otherwise =
let
vars :: [Name]
vars = TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr_ flag]
bndrs
freshes :: [Name]
freshes = [Name] -> Type -> [Name]
forall t. Data t => [Name] -> t -> [Name]
evades [Name]
vars Type
t
freshTyVarBndrs :: [TyVarBndr_ flag]
freshTyVarBndrs = (Name -> TyVarBndr_ flag -> TyVarBndr_ flag)
-> [Name] -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. Name -> TyVarBndr_ flag -> TyVarBndr_ flag
tyVarBndrSetName [Name]
freshes [TyVarBndr_ flag]
bndrs
substs :: [(Name, Type)]
substs = [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vars (Name -> Type
VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
freshes)
in
[(Name, Type)] -> [TyVarBndr_ flag] -> a
k ((Name, Type)
vt(Name, Type) -> [(Name, Type)] -> [(Name, Type)]
forall a. a -> [a] -> [a]
:[(Name, Type)]
substs) [TyVarBndr_ flag]
forall flag. [TyVarBndr_ flag]
freshTyVarBndrs
doSubsts :: SubstTypeVariable a => [(Name, Type)] -> a -> a
doSubsts :: [(Name, Type)] -> a -> a
doSubsts [(Name, Type)]
substs a
x = ((Name, Type) -> a -> a) -> a -> [(Name, Type)] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, Type) -> a -> a
forall a. SubstTypeVariable a => (Name, Type) -> a -> a
subst a
x [(Name, Type)]
substs
substInType :: (Name,Type) -> Type -> Type
substInType :: (Name, Type) -> Type -> Type
substInType = (Name, Type) -> Type -> Type
forall a. SubstTypeVariable a => (Name, Type) -> a -> a
subst
substInCon :: (Name,Type) -> Con -> Con
substInCon :: (Name, Type) -> Con -> Con
substInCon = (Name, Type) -> Con -> Con
forall a. SubstTypeVariable a => (Name, Type) -> a -> a
subst